perm filename ILISP.MAC[UCI,SYS] blob
sn#088636 filedate 1974-02-27 generic text, type T, neo UTF8
SUBTTL AC DEFINITIONS AND EXTERNALS --- PAGE 1
TITLE ILISP INTERPRETER
TWOSEG
;SYSPRG==667 ;PPN OF LISP SYSTEM - SET TO 0 FOR SYS:
;SYSPN==2 ;SAME HERE
IFNDEF SYSPRG,<SYSPRG==0
SYSPN==0>
;ALVINE==1 ;1 FOR ALVINE, 0 FOR NO ALVINE
IFNDEF ALVINE,<ALVINE==0>
;HASH==1 ;1 FOR SETTING # OF HASH BUCKETS AT SYS. INIT. TIME
IFNDEF HASH,<HASH==0>
;STPGAP==1 ;1 FOR STOPGAP, 0 TO DELETE IT
IFNDEF STPGAP,<STPGAP==0>
IF1,<PURGE CDR,DF>
STANSW==1 ;1 FOR STANFORD, 0 FOR CHRISTIANS
IFNDEF STANSW,<STANSW==0>
MLON
INUMIN=377777
INUM0=<INUMIN+777777>/2
BCKETS==177
IFE SYSPRG,<DEFINE SYSDEV <SIXBIT /SYS/>>
IFN SYSPRG,<DEFINE SYSDEV <SIXBIT /DSK/>>
DEFINE SYSNAM <SIXBIT /ILISP2/> ; *** MJC
;accumulator definitions
;`sacred' means sacred to the interpreter
;`marked' means marked from by the garbage collector
;`protected' means protected during garbage collection
NIL=0 ;sacred, marked, protected ;atom head of NIL
A=1 ;marked, protected ;results of functions and first arg of subrs
B=A+1 ;marked, protected ;second arg of subrs
C=B+1 ;marked, protected ;third arg of subrs
AR1=4 ;marked, protected ;fourth arg of subrs
AR2A=5 ;marked, protected ;fifth arg of subrs
T=6 ;marked, protected ;minus number of args in LSUBR call
TT=7 ;marked, protected
REL=10 ;marked, protected
S=11 ;$$NOW USED FOR ATOM RELOCATION AND GARBAGE COLLECTOR
D=12
R=13 ;protected
P=14 ;sacred, protected ;regular push down stack pointer
F=15 ;sacred ;free storage list pointer
FF=16 ;sacred ;full word list pointer
SP=17 ;sacred, protected ;special pushdown stack pointer
NACS==5 ;number of argument acs
X==0 ;X indicates impure (modified) code locations
TEN==↑D10
;UUO definitions
;UUOs used to call functions from compiled code
;the number of arguments is given by the ac field
;the address is a pointer either to the function
;name or the code of the function
OPDEF FCALL [34B8] ;ordinary function call-may be changed to PUSHJ
OPDEF JCALL [35B8] ;terminal function call-may be changed to JRST
OPDEF CALLF [36B8] ;like call but may not be changed to PUSHJ
OPDEF JCALLF [37B8] ;like jcall but may not be changed to JRST
;error UUOs
OPDEF ERR1 [1B8] ;ordinary lisp error ;gives backtrace
OPDEF ERR2 [2B8] ;space overflow error ;no backtrace
OPDEF ERR3 [3B8] ;ill. mem. ref.
OPDEF STRTIP [4B8] ;print error message and continue
;system UUOs
OPDEF TTYUUO [51B8]
OPDEF INCHRW [TTYUUO 0,]
OPDEF OUTCHR [TTYUUO 1,]
OPDEF OUTSTR [TTYUUO 3,]
OPDEF INCHWL [TTYUUO 4,]
OPDEF INCHSL [TTYUUO 5,]
OPDEF CLRBFI [TTYUUO 11,]
OPDEF SKPINC [TTYUUO 13,]
OPDEF TALK [PUSHJ P,TTYCLR] ;this is to turn off control O.
;when ttyser lets you do this
;easily, change me
;I/O bits and constants
TTYLL==105 ;teletype linelength
LPTLL==160 ;line printer linelength
MLIOB==203 ;max length of I/O buffer
NIOB==2 ;no of I/O buffers per device
NIOCH==17 ;number of I/O channels
FSTCH==1 ;first I/O channel
TTCH==0 ;teletype I/O channel
BLKSIZE==NIOB*MLIOB+COUNT+1
INB==2
OUTB==1
AVLB==40
DIRB==4
;special ASCII characters
ALTMOD==175
SPACE==40 ;space
IGCRLF==31 ;ignored cr-lf
RUBOUT==177
LF==12
CR==15
TAB==11
BELL==7
DBLQT==42 ;double quote "
;byte pointer field definitions
ACFLD==14 ;ac field
XFLD==21 ;index field
OPFLD==10 ;opcode field
ADRFLD==43 ;adress field
;external and internal symbols
EXTERNAL JOB41 ;instruction to be executed on UUO
EXTERNAL JOBAPR ;address of APR interupt routines
EXTERNAL JOBCNI ;interupt condition flags
EXTERNAL JOBFF ;first location beyond program
EXTERNAL JOBREL ;address of last legal instruction in core image
EXTERNAL JOBREN ;reentry address
EXTERNAL JOBSA ;starting address
EXTERNAL JOBSYM ;address of symbol table
EXTERNAL JOBTPC ;program counter at time of interupt
EXTERNAL JOBUUO ;uuo is put here with effective address computed
EXTERNAL JOBOPC ;$$FOR NEW REENTER FEATURES
EXTERNAL JOBHRL ;HIGH SEGMENT BOUNDARY
;apr flags
PDOV==200000 ;push down list overflow
MPV==20000 ;memory protection violation
NXM==10000 ;non-existant memory referenced
APRFLG==PDOV+MPV+NXM ;any of the above
;RE-ENTER CONTROL CHARACTERS
CNTLH==10
CNTLE==5
CNTLB==2
CNTLZ==32
CNTLG==7
;system uuos
APRINI==16
RESET==0
STIME==27
DEVCHR==4
EXIT==12
CORE==11
SETUWP==36
GETSEG==40
;REMOTE MACRO
DEFINE REMOTE (TX)
< HERE1 <TX>>
DEFINE HERE1 (NEW,OLD,%G)
< DEFINE %G
< NEW>
DEFINE REMOTE (TX)
< HERE1 <TX>,<OLD
%G
>>>
DEFINE HERE
< DEFINE HERE1 (XX,YY)
< YY>
REMOTE>
SALL
SUBTTL TOP LEVEL AND INITIALIZATION --- PAGE 2
PAGE
SHRST==400000
RELOC SHRST
REMOTE<
LISPGO: SKIPE GCFLG ;$$CHECK FO GARBAGE COLLECTION
PUSHJ P,GCING ;$$QUEUE THE REQUEST
; CAME 0,STNIL ;$$UNBIND STACK IF REGS LOOK OK *** MJC
; JRST GETHGH ;GO GET HIGH SEGMENT *** MJC
; MOVE B,SC2 *** MJC
; PUSHJ P,UBD ;$$UNBIND STACK *** MJC
; JRST STRT ;go to re-allocator *** MJC
;GETHGH: CALLI RESET *** MJC
; MOVSI A,1 *** MJC
;IFE STANSW,< CALLI A,CORE ;ELIMINATE ANY OLD HIGH SEGS. *** MJC
; HALT > *** MJC
;*** IFN STANSW,< CALLI A,400015
;*** HALT>
;*** MOVEI A,HGHDAT
;*** CALLI A,GETSEG ;GET THE PROPER HIGH SEG
;*** HALT
MOVE A,HGHDAT+1 ; Get high segment name *** MJC
CALLI A,400016 ; Attach to high seg if poss. *** MJC
CAIN A,4 ; If err=4 (seg alrdy there) ok too *** MJC
JRST SGPROT ; Success! *** MJC
CALLI 400017 ; Detach stray segments. *** MJC
MOVE A,HGHDAT ; Get device name for OPEN. *** MJC
MOVEM A,INTDAT+1 ; Move into parm list for OPEN. *** MJC
OPEN 0,INTDAT ; Init ch 0 to dump mode. *** MJC
JRST NOSEG ; Couldn't do it? *** MJC
MOVE A,SGPPPN ; Get ppn of high seg file. *** MJC
MOVEM A,HGHDAT+4 ; Store for LOOKUP. *** MJC
LOOKUP 0,HGHDAT+1 ; Find file containing high seg *** MJC
JRST NOSEG ; No high seg file -- collapse *** MJC
HLRE A,HGHDAT+4 ; Ppn was replaced by -length *** MJC
MOVNS A ; Fix up for CORE2. *** MJC
CALLI A,400015 ; Grab core for high segment. *** MJC
JRST NOSEG ; Can't get it? *** MJC
MOVE A,HGHDAT+1 ; Name the high segment. *** MJC
CALLI A,400036 ; SEGNM2 uuo. *** MJC
JRST NOSEG ; Pretty weird. *** MJC
MOVEI A,SHRST-1 ; For dump mode input. *** MJC
HRRM A,HGHDAT+4 ; *** MJC
INPUT 0,HGHDAT+4 ; Fill high seg with goodies. *** MJC
CLOSE 0,1 ; Destroy fingerprints. *** MJC
SGPROT: MOVEI A,DEBUGO ;SET THE REE ADDRESS
HRRM A,JOBREN
MOVE A,HGHDAT+1 ; Decide whether or not to *** MJC
CAME A,[SYSNAM] ; protect segment. *** MJC
JRST STRT ; Segment was not system's *** MJC
CALLI 36 ; Write-protect segment. *** MJC
HALT ; rather than turn him loose. *** MJC
JRST STRT ;GO TO ALLOCATE STORAGE
NOSEG: OUTSTR [ASCIZ/CAN'T GET HIGH SEGMENT!/] ; *** MJC
HALT ; *** MJC
HGHDAT: SYSDEV ; All used by LOOKUP and ENTER *** MJC
SYSNAM ; High segment job & file name *** MJC
0 ; High seg file extension. *** MJC
0
0 ; PRG,PPN of high seg file. *** MJC
; Also file length after LOOKUP *** MJC
; Used as dump wd cmd list. *** MJC
0
INTDAT: 17 ; Data mode. *** MJC
SYSDEV ; Dev name (defd before OPEN) *** MJC
0 ; Buffer indicators (none) *** MJC
SGPPPN: XWD SYSPRG,SYSPN ; High seg file area *** MJC
PATCHL: BLOCK 20
>
DDT: SETOM ERINT ;$$SET CONTROL H WITHOUT GOING THRU REE
JRST @JOBOPC ;$$AND CONTINUE
DEBUGO: SKIPE GCFLG# ;CHECK GARBASE COLLECT.
PUSHJ P,GCING ;QUEUE INTERRUPT
INCHRW 0 ;READ THE CONTROL CHARACTER
CAIN 0,CNTLH
JRST [MOVE 0,STNIL
JRST DDT]
CAIN 0,CNTLE
JRST [MOVE 0,STNIL
MOVEI 1,NIL
JRST ERR]
CAIN 0,CNTLB
JRST [MOVE 0,STNIL
SETOM ERINT
PUSHJ P,SPDLPT
PUSHJ P,SPREDO
JRST LSPRET]
CAIN 0,CNTLZ
JRST [MOVE 0,STNIL
JRST LSPRET]
CAIN 0,CNTLG
JRST [MOVE 0,STNIL
JRST RERX]
JRST DEBUGO+2 ;NOT A CONTROL CHARACTER
;MUST BE SOMETHING IN THE BUFFER SO TRY AGAIN
START: CALLI RESET ;random initializations for lisp interupts
MOVE [JSR UUOH]
MOVEM JOB41
MOVEI APRINT
MOVEM JOBAPR
MOVEI APRFLG
CALLI APRINI
SETZM GCFLG
HRRZI 17,1
IFN ALVINE,<SETZB 0,PSAV1>
IFE ALVINE,<SETZ 0,>
BLT 17,17 ;clear acs
MOVE S,ATMOV ;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
LSPRT1: SETZM BIOCHN(S) ;$$CLEAR VARS FOR BREAK PACKAGE
SETZM BPMPT(S) ;$$(#%IOCHNAS%#, #%PROMPTS%#, AND #%INDENT)
MOVEI A,INUM0
MOVEM A,BINDNT(S)
SETZM ERINT# ;$$TURN OFF INTERRUPT FLAG
SETOM ERRSW ;print error messages
CLEARM ERRTN# ;return to top level on errors
SETOM PRVCNT# ;initialize counter for errio
MOVE P,C2# ;initial reg pdl ptr
MOVE SP,SC2# ;initial spec pdl ptr
MOVE A,LSPRMP# ;$$INITIALIZE TO TOP LEVEL PROMPT
;$$CAN BE CHANGED BY INITPROMPT
PUSHJ P,PROMPT ;$$
SETZM SMAC ;$$CLEAR SPLICE LIST (JUST IN CASE)
MOVE S,ATMOV ;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
PUSHJ P,TTYRET ;(outc nil t)(inc nil t)return output for gc message
HRROI 0,CNIL2(S) ;initialize nil
MOVEM 0,STNIL# ;$$SAVE FOR REG CHECK AT START TIME
IFN HASH,<
SKIPE HASHFG#
JRST REHASH ;rehash if necessary>
SKIPN F
PUSHJ P,AGC ;garbage collect only if necessary
SKIPN BSFLG# ;initial bootstrap for macros
JRST BOOTS
SKIPE A,INITF
CALLF (A) ;evaluate initialization function
PUSHJ P,TTYRET ;return all i/o to tty
PUSHJ P,TERPRI
SKIPE GOBF# ;garbaged oblist flag
STRTIP [SIXBIT /GARBAGED OBLIST←!/]
SETZM GOBF
SKIPE BPSFLG#
JRST BINER2 ;binary program space exceeded by loader
LISP1: MOVE S,ATMOV# ;$$MAKE SURE REL STAYS
;$$SET UP - BELT AND SUSPENDERS TECHNIQUE
PUSHJ P,READ ;this is the top level of lisp
PUSHJ P,EVAL
PUSHJ P,PRINT
PUSHJ P,TERPRI
JRST LISP1
PAGE
INITFN: EXCH A,INITF#
POPJ P,
;return from lisp error
LSPRET: PUSHJ P,TERPRI
MOVE B,SC2 ;RETURN FROM BELL
PUSHJ P,UBD ;unbind specpdl
JRST LSPRT1
.RSET: EXCH A,RSTSW#
POPJ P,
;BOOTSTRAPPER FOR USER'S INIT FILE
BOOTS: SETOM BSFLG
MOVE A,[POINT 7,[ASCII /(ERRSET[INC(INPUT DSK:(INIT.LSP]NIL)[(EVAL(READ]/]]
MOVEM A,BOOPT#
MOVEI A,BSTYI
PUSHJ P,READP1
PUSHJ P,EVAL
JUMPE A,BOOTOT
MOVEI A,BSTYI
PUSHJ P,READP1
PUSH P,A
MOVE A,(P)
PUSHJ P,ERRSET
CAIE A,$EOF$(S)
JRST .-3
BOOTOT: PUSHJ P,EXCISE
JRST ERR
BSTYI: ILDB A,BOOPT
POPJ P,
PAGE
SUBTTL APR INTERRUPT ROUTINES --- PAGE 3
;arithmetic processor interupts
;mem. protect. violation, nonex. mem. or pdl overflow
APRINT: MOVE R,JOBCNI ;get interupt bits
TRNE R,MPV+NXM ;what kind
ERR3 @JOBTPC ;an ill mem ref-will become JRST ILLMEM
JUMPN NIL,MES21 ;a pdl overflow
STRTIP [SIXBIT /←PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
JRST START
MES21: SETZM JOBUUO
SKIPL P
STRTIP [SIXBIT /←REG !/]
SKIPL SP
STRTIP [SIXBIT /←SPEC !/]
SKIPE JOBUUO
SPDLOV: ERR2 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
TRNE R,PDOV
SKIPE JOBUUO
HALT ;lisp should not be here
BINER2: SETZM BPSFLG
ERR2 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]
ILLMEM: LDB R,[POINT 4,@JOBTPC,XFLD] ;get index field of bad word
CAIE R,F ;does it contain f
ERR3 @JOBTPC ;no! error
PUSHJ P,AGC ;yes! garbage collect
JRST @JOBTPC ;and continue
SUBTTL UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 4
UUOMIN==1
UUOMAX==4
REMOTE<UUOH: X ;jsr location
JRST UUOH2>
UUOH2: MOVEM T,TSV#
MOVEM TT,TTSV#
LDB T,[POINT 9,JOBUUO,OPFLD] ;get opcode
CAIGE T,34 ;is it a function call
JRST ERROR ;or a LISP error
HLRE R,@JOBUUO
AOJN R,UUOS
LDB T,[POINT 4,JOBUUO,ACFLD]
CAILE T,15
MOVEI R,-15(T)
HRRZ T,@JOBUUO
UUOH1: HLRZ TT,(T)
HRRZ T,(T)
CAIN TT,SUBR(S)
JRST @UUST(R)
CAIN TT,FSUBR(S)
JRST @UUFST(R)
CAIN TT,LSUBR(S)
JRST @UULT(R)
CAIN TT,EXPR(S)
JRST @UUET(R)
CAIN TT,FEXPR(S)
JRST @UUFET(R)
HRRZ T,(T)
JUMPN T,UUOH1
PUSH P,A
PUSH P,B
HRRZ A,JOBUUO
MOVEI B,VALUE(S)
PUSHJ P,GET
JUMPN A,[ HRRZ TT,(A)
POP P,B
POP P,A
JRST UUOEX1]
HRRZ A,JOBUUO
PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED UUO!/]
PAGE
SKIPA T,TT
UUOSBR: HLRZ T,(T)
MOVE TT,JOBUUO
HRLI T,(PUSHJ P,)
TLNE TT,1000 ;1000 means no push
TLCA T,34600 ;<PUSHJ P,>xor<JRST>
PUSH P,UUOH
SOS UUOH
HRRZ D,UUOH
CAIG D,SHRST
JRST .+3
SKIPE WRTSTS
JRST .+3
REMOTE<UUOCL: TLNN TT,2000> ;2000 means no clobber
XCT UUOCL
MOVEM T,@UUOH
MOVE TT,TTSV
EXCH T,TSV
JRST @TSV
UUOS: HRRZ TT,JOBUUO
CAILE TT,@GCPP1
CAIL TT,@GCP1
JRST UUOSBR-1
JRST .+2
UUOEXP: HLRZ TT,(T)
UUOEX1: LDB T,[POINT 5,JOBUUO,ACFLD]
TRZN T,20
PUSH P,UUOH
PUSH P,TT
JUMPE T,IAPPLY
CAIN T,17
MOVEI T,1
MOVNS T
HRLZ TT,T
PUSH P,A(TT)
AOBJN TT,.-1
JRST IAPPLY
PAGE
ARGPDL: LDB T,[POINT 4,JOBUUO,ACFLD]
MOVNS T
HRLZ R,T
ARGP1: JUMPE R,(TT)
PUSH P,A(R)
AOBJN R,.-1
JRST (TT)
QTIFY: PUSHJ P,NCONS
MOVEI B,CQUOTE(S)
JRST XCONS
QTLFY: MOVEI A,0
QTLFY1: JUMPE T,(TT)
EXCH A,(P)
PUSHJ P,QTIFY
POP P,B
PUSHJ P,CONS
AOJA T,QTLFY1
PDLARG: JRST .+NACS+2(T)
POP P,A+5
POP P,A+4
POP P,A+3
POP P,A+2
POP P,A+1
POP P,A
JRST (TT)
NOUUO: MOVSI B,(TLNN TT,)
SKIPE A
MOVSI B,(TLNA)
HLLM B,UUOCL
EXCH A,NOUUOF#
POPJ P,
PAGE
;r=0 => compiler calling a -
;r=1 => compiler calling a lsubr
;r=2 => compiler calling f type
UUST: UUOSBR
UUOS1 ;calling l its a subr
UUOS2 ;calling f
UUFST: UUOS9 ;calling - its a f
UUOS10 ;calling l
UUOSBR
UULT: UUOS7 ;calling - its a l
UUOSBR
UUOS8
UUET: UUOEXP
UUOS5 ;calling l its an expr
UUOS6 ;calling f its an expr
UUFET: UUOS3 ;calling - its a fexpr
UUOS4 ;calling l
UUOEXP
UUOS1: HLRZ R,(T)
MOVE T,TSV
JSP TT,PDLARG
JRST (R)
UUOS3: PUSH P,(T)
JSP TT,ARGPDL
UUOS4A: JSP TT,QTLFY
MOVEI TT,1
DPB TT,[POINT 4,JOBUUO,ACFLD]
UUOS6A: POP P,TT
HLRZS TT
JRST UUOEX1
UUOS4: PUSH P,(T)
MOVE T,TSV
JRST UUOS4A
PAGE
UUOS5: HLRZ R,(T)
MOVE T,TSV
JSP TT,PDLARG
MOVE TT,R
JRST UUOEX1
UUOS6: PUSH P,(T)
PUSH P,UUOH
PUSH P,JOBUUO
JSP TT,ILIST
JSP TT,PDLARG
POP P,JOBUUO
POP P,UUOH
JRST UUOS6A
UUOS8: SKIPA TT,CILIST
UUOS7: MOVEI TT,ARGPDL
HRRM TT,UUOS7A
MOVE TT,JOBUUO
TLNN TT,1000
PUSH P,UUOH
HLRZ TT,(T)
JRST @UUOS7A ;OR ILIST
REMOTE<UUOS7A: ARGPDL>
UUOS9: PUSH P,T
JSP TT,ARGPDL
UUS10A: JSP TT,QTLFY
MOVSI T,2000
IORM T,JOBUUO
POP P,T
JRST UUOSBR
UUOS10: PUSH P,T
MOVE T,TSV
JRST UUS10A
SUBTTL ERROR HANDLER AND BACKTRACE --- PAGE 5
;subroutine to print sixbit error message
ERRSUB: MOVSI A,(POINT 6,0)
HRR A,JOBUUO
MOVEM A,ERRPTR#
ERRORB: ILDB A,ERRPTR
CAIN A,01 ;conversion from sixbit
POPJ P,
CAIN A,77
JRST [ PUSHJ P,TERPRI
JRST ERRORB]
ADDI A,40
PUSHJ P,TYO
JRST ERRORB
;subroutine to return output to previously selected device
OUTRET: SKIPL PRVCNT ;if prvcnt<0 then there was no device deselect
SOSL PRVCNT ;when prvcnt goes negative, then reselect
POPJ P,
PUSH P,PRVSEL# ;previously selected output
POP P,TYOD
POPJ P,
;subroutine to force error messages out on tty
ERRIO: MOVE B,ERRSW
CAIE B,INUM0 ;inum0 specifies to print message on selected device
AOSLE PRVCNT ;only if prvcnt already <0 does deselection occur
POPJ P,
TALK ;undo control o
MOVE B,[JRST TTYO]
EXCH B,TYOD
MOVEM B,PRVSEL
POPJ P,
;ERRTN: 0 ;0 => top level *
;- => pdl to reset to - stored by errorset
;+ => string tyo pout rtn flag
REMOTE<ERRSW: -1> ;0 means no prnt on error *
PAGE
;subroutine to search oblist for closest function to address in r
ERSUB3:
MOVEI A,QST(S)
HRROI NIL,CNIL2(S)
HRLZ B,INT1
MOVNS B
SETZB AR2A,GOBF
PUSH P,JOBAPR
MOVEI C,[ SETOM GOBF
JRST ERRO2G]
HRRM C,JOBAPR
HLRZ C,@RHX5
ERRO2B: JUMPE C,[ AOBJN B,.-1
POP P,JOBAPR ;oblist done, restore
JRST PRINC] ;print closest match
HLRZ TT,(C)
ERRO2C: HRRZ TT,(TT)
JUMPE TT,ERRO2G
HLRZ AR1,(TT)
CAIN AR1,LSUBR(S)
JRST ERRO2H
CAIE AR1,SUBR(S)
CAIN AR1,FSUBR(S)
JRST ERRO2H
HRRZ TT,(TT)
JRST ERRO2C
ERRO2H: HRRZ TT,(TT)
HLRZ TT,(TT)
CAMLE TT,AR2A ;le to prefer car to quote
CAMLE TT,R
JRST ERRO2G
MOVE AR2A,TT
HLRZ A,(C)
ERRO2G: HRRZ C,(C)
JRST ERRO2B
PAGE
;dispatcher for error message uuos
ERROR: MOVEI A,APRFLG
CALLI A,APRINI ;enable interupts
LDB A,[POINT 9,JOBUUO,OPFLD] ;get opcode
CAIL A,UUOMIN ;what
CAILE A,UUOMAX ;is it?
JRST ILLUUO ;an illegal opcode
JRST @ERRTAB-UUOMIN(A) ;or LISP error
ERRTAB: ERROR1 ;1 ;ordinary LISP error
ERRORG ;2 ;space overflow error
ERROR2 ;3 ;ill. mem. ref.
STRTYP ;4 ;print error message and continue
ERRORG: MOVE P,ERRTN ;IF IN ERRSET, RESTORE P TO THAT LEVEL
SKIPN P
MOVE P,C2 ;else to top level
SETOM UUO2# ;$$ AND DON'T ENTER ERRORX
ERROR1: SKIPN ERRSW
JRST ERREND ;dont print message, call (err nil)
PUSHJ P,ERRIO ;print message on tty
PUSHJ P,TERPRI
PUSHJ P,ERRSUB ;print the message
JRST ERRBK ;go the backtrace
STRTYP: PUSHJ P,ERRIO
PUSHJ P,ERRSUB ;print message and continue
PUSHJ P,OUTRET
JRST @UUOH
;USER ENTRY TO ERROR HANDLER, PRINTS ARG IF NON-NIL
.ERROR: JUMPE A,ERREND
SKIPN ERRSW
JRST ERREND
PUSHJ P,ERRIO
PUSHJ P,TERPRI
PUSHJ P,PRINC
JRST ERREND
PAGE
ERROR2: HRRZ A,JOBUUO
MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
JRST ERSUB2
ILLUUO: HRRZ A,UUOH
MOVEI B,[SIXBIT / ILL UUO FROM !/]
ERSUB2: SKIPN ERRSW
JRST ERREND ;dont print message
PUSH P,A
PUSH P,B
PUSHJ P,ERRIO
PUSHJ P,TERPRI
PUSHJ P,PRINL2 ;print number
POP P,A
STRTIP (A) ;print message
POP P,R
PUSHJ P,ERSUB3 ;print nearest oblist match
ERRBK:
IFN ALVINE,<
SKIPE BACTRF
PUSHJ P,BKTRC ;print backtrace
>
PUSHJ P,OUTRET ;return to previous device
ERREND: PUSHJ P,%CLRBFI ;CLEAR INPUT BUFFER
SKIPN UUO2 ;$$NO ERRORX IF OVERFLOW ERROR
JRST .+3
SETZM UUO2 ;$$RESET TO ZERO
JRST RERX ;$$BOUNCE BACK TO ERRORX
SKIPN RSTSW ;$$NEW *RSET FEATURE
JRST ERR ;$$IF (*RSET NIL) UNBIND AND GO TO TOP LEVEL
SKIPN ERRSW ;$$NO ERRORX IF NO MESSAGE
JRST ERR ;$$
MOVEI A,ERRORX(S) ;$$ELSE SET TO CALL ERROR HANDLER
MOVEI B,NIL ;$$CREATE FORM (ERRORX)
CEV: PUSHJ P,CONS ;$$
JRST EVAL ;$$AND EVALUATE IT
ERR: SETZM INHERR ;CLEAR RERX FLAG JUST IN CASE
CAIN A,ERRORX(S) ;$$BOUNCE TO ERRORX IF A=ERRORX
JRST RERX
ERR2: SKIPN ERRTN
JRST LSPRET ;not in an errset, or bad error -- go to top level
MOVE P,ERRTN
ERR1: POP P,B
PUSHJ P,UBD ;unbind to previous errset
POP P,ERRSW
POP P,ERRTN
SKIPN INHERR#
JRST ERRP4 ;and proceed
RERX: SETZM INHERR ;$$ POP TO A BREAK ERRSET
MOVE B,ERRSW
CAIE B,ERRORX(S)
SETOM INHERR
JRST ERR2
ERRSET: PUSH P,PA3
PUSH P,PA4
PUSH P,ERRTN
PUSH P,ERRSW
PUSH P,SP
MOVEM P,ERRTN
HRRZ C,(A)
HLRZ C,(C)
MOVEM C,ERRSW
HLRZ A,(A)
PUSHJ P,EVAL
PUSHJ P,NCONS
SETZM INHERR ;CLEAR RERX FLAG
JRST ERR1
SYSCLR: SETZM BSFLG ;FUNCTION TO MAKE SYSTEM LOOK NEW
JRST FALSE ;MIGHT BE EXTENDED LATER
PAGE
;error messages
RMERR: MOVE A,T ;$$ BAD READ MACRO, GET THE NAME
PUSHJ P,EPRINT ;$$
ERR1 [SIXBIT /UNDEFINED READ MACRO!/]
BNDERR: PUSHJ P,EPRINT ;$$ATTEMPT TO REBIND NIL OR T
ERR1 [SIXBIT /CANNOT BE RE-BOUND!/]
RPAERR: PUSHJ P,EPRINT ;$$PRINT OUT OFFENDING ITEM
ERR1 [SIXBIT /IS AN ATOM, CAN'T BE RPLACA'D!/]
RPDERR: PUSHJ P,EPRINT ;$$
ERR1 [SIXBIT /CAN'T BE RPLACD'D (NIL OR INUM)!/]
DOTERR: SETZM OLDCH
ERR1 [ SIXBIT /DOT CONTEXT ERROR!/]
UNDFUN: HLRZ A,(AR1)
PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
UNBVAR: PUSHJ P,EPRINT
ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
NONNUM: ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
NOPNAM: ERR1 [SIXBIT /NO PRINT NAME - INTERN!/]
NOLIST: ERR1 [SIXBIT /NO LIST-MAKNAM!/]
TOMANY: ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
TOOFEW: ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
UNDTAC: HRRZ A,(C)
UNDTAG: PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
SETERR: PUSHJ P,EPRINT ;$$BAD SET OR SETQ
ERR1 [SIXBIT /CAN'T BE SET TO A VALUE - SET OR SETQ!/]
EG1: PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED PROG TAG-GO!/]
EG2: PUSHJ P,EPRINT
ERR1 [SIXBIT /GO WITH NO PROG!/]
EG3: ERR1 [SIXBIT /RETURN WITH NO PROG!/]
PAGE
IFN ALVINE,<
;backtrace subroutine
BKTRC: MOVEI D,-1(P)
MOVN A,BACTRF
ADDI A,INUM0
JUMPL A,[ ADD A,P ;backtrace specific number
JRST .+3]
SKIPN A,ERRTN ;backtrace to previous errset
MOVE A,C2 ;or top level
HRRZM A,BAKLEV#
STRTIP [SIXBIT /←BACKTRACE←!/]
BKTR2: CAMG D,BAKLEV
JRST FALSE ;done
HRRZ A,(D) ;get pdl element
CAIGE A,FS(S)
JUMPN A,.+2 ;this is (hopefully) a true program address
SOJA D,BKTR2 ;not a program address, continue
CAIN A,ILIST3
JRST BKTR1A ;argument evaluation
BKTR1B: CAIN A,CPOPJ
JRST [ HLRZ A,(D) ;calling a function
PUSHJ P,PRINC
XCT "-",CTY
STRTIP [SIXBIT /ENTER !/]
SOJA D,BKTR2]
HLRZ B,-1(A)
CAILE B,(JCALLF 17,@(17))
CAIN B,(PUSHJ P,) ;tests for various types of calls
CAIGE B,(FCALL)
SOJA D,BKTR2 ;not a proper function call
PUSH P,-1(A) ;save object of function call
MOVEI R,-1(A) ;location of function call
PUSHJ P,ERSUB3 ;print closest oblist match
MOVEI A,"-"
PUSHJ P,TYO
POP P,R
TLNE R,17
HRRZ R,ERSUB3 ;qst -- cant handle indexed calls
HRRZS R
HLRO B,(R)
AOSN B
JRST [ HRRZ A,R ;was calling an atomic function
PUSHJ P,PRINC ;print its name
JRST .+2]
PUSHJ P,ERSUB3 ;was calling a code location -- print closest match
MOVEI A," "
PUSHJ P,TYO
BKTR1: SOJA D,BKTR2 ;continue
BKTR1A: HRRZ B,-1(D)
CAIE B,EXP2
CAIN B,ESB1
JRST .+2
JRST BKTR1B ;hum, not really evaluating arguments
HLRE B,-1(D)
ADD B,D
HLRZ A,-3(B)
JUMPE A,BKTR1
PUSHJ P,PRINC
XCT "-",CTY
STRTIP [SIXBIT /EVALARGS !/]
JRST BKTR1
>
BAKGAG: EXCH A,BACTRF#
POPJ P,
SUBTTL TYI AND TYO --- PAGE 6
;input
ITYI: PUSHJ P,TYI
FIXI: ADDI A,INUM0
POPJ P,
TYI: MOVEI AR1,1
PUSHJ P,TYIA
JUMPE A,.-1
CAME A,IGSTRT ;start of comment or ignored cr-lf
POPJ P,
PUSHJ P,COMMENT
JRST TYI+1
TYIA: SKIPE A,OLDCH
JRST TYI1
TYID: XCT TYI2
REMOTE<TYI2: JRST TTYI> ;sosg x for other device input
;other device input
JRST TYI2X
TYI3B: ILDB A,@TYI3# ;pointer
XCT TYI3A
REMOTE<TYI3A: TDNN AR1,@X> ;pointer
POPJ P,
IFN STPGAP,<
MOVE A,@TYI3A
CAMN A,[<ASCII / />+1] ;page mark for stopgap
AOSA PGNUM ;increment page number
MOVEM A,LINUM
>
MOVNI A,5
ADDM A,@TYI2 ;adjust character count for line number
AOS @TYI3 ;increment byte pointer over line number and tab
JRST TYID
REMOTE< TYI2X: INPUT X,
TYI2Y: STATZ X,740000
ERR1 AIN.8 ;input error
TYI2Z: STATO X,20000
JRST TYI3B ;continue with file
JRST TYI2Q ;END OF FILE>
TYI2Q: PUSH P,T
PUSH P,C
PUSH P,R
PUSH P,AR1
MOVE A,INCH
HRRZ C,CHTAB(A) ;get location of data for this channel
HLRZ T,CHTAB(A) ;inlst -- remaining files to input
JUMPE T,TYI2E ;none left -- stop
PUSHJ P,SETIN ;start next input
POP P,AR1
POP P,R
POP P,C
POP P,T
JRST TYI
TYI2E: PUSHJ P,INCNT ;(inc nil t)
TALK ;turn off control o
MOVEI A,$EOF$(S) ;we are done
JRST ERR
IFN STPGAP,<
PGLINE: MOVE C,[POINT 7,LINUM]
PUSHJ P,NUM10 ;convert ascii line number to a integer
ADDI A,INUM0
MOVE B,PGNUM
ADDI B,INUM0+1
JRST XCONS>
REMOTE< OLDCH: 0
IFN STPGAP,<
PGNUM: 0
LINUM: 0
0>> ;zero to terminate num10
;TTYECHO - COMPLEMENTS THE TTY: ECHO BIT AND RETURNS T IF THE ECHO
; IS BEING TURNED ON AND NIL IF IT IS BEING TURNED OFF
; - TAKES NO ARGUMENTS
ECHO: SETO A,
TTYUUO 6,A ;GET STATUS BITS
TLC A,4 ;COMPLEMENT THE ECHO BIT
TTYUUO 7,A ;RESTORE THE BITS
TLNE A,4 ;TEST TO GET FINAL VALUE
JRST FALSE
JRST TRUE
;CLRBFI - CLEARS TTY INPUT BUFFER FOR USER ERRORS
; - 0 ARGS AND RETURNS NIL
%CLRBFI:CLRBFI ;CLEAR BUFFER
SETZM SMAC ;CLEAR SPLICE LIST
SETZM OLDCH ;CLEAR LAST CHAR.
JRST FALSE
PAGE
;teletype input
TTYI: SKIPE DDTIFG
JRST TTYID
INCHSL A ;single char if line has been typed
JRST [TALK ;turn off control o, this
;can be omitted when ttyser is fixed
OUTCHR PROMCH# ;$$OUTPUT PROMPT CHARACTER
INCHWL A ;wait for a line
JRST .+1]
TTYXIT: CAIE A,BELL
POPJ P,
IFN ALVINE,<
SKIPE PSAV1# ;bell from alvine?
JRST [ MOVE P,PSAV1 ;yes, return to alvine
JRST @ED1];$$DOUBLY IMPROVED MAGIC>
MOVEI A,NIL ;$$ RETURN NIL AS THE VALUE
JRST RERX ;$$ RETURN TO AN ERRORX ERRSET
TTYID: TALK ;turn off control o, remove this when ttyser works
INCHRW A ;single character input ddt submode style
CAIE A,RUBOUT
JRST TTYXIT
OUTCHR ["\"] ;echo backslash
SKIPE PSAV
JRST RDRUB ;rubout in read resets to top level of read
MOVEI A,RUBOUT
POPJ P,
PROMPT: SKIPN A
SKIPA A,PROMCH
MOVEI A,-INUM0(A) ;$$CHANGE FROM INUM
EXCH A,PROMCH# ;$$CHANGE PROMPT CHARACTER AND RETURN OLD ONE
MOVEI A,INUM0(A) ;$$CHANGE TO INUM
POPJ P, ;$$
INTPRP: SKIPN A
SKIPA A,LSPRMP
EXCH A,LSPRMP# ;$$ EXCHANGE FOR OLD TOP LEVEL PROMPT
POPJ P, ;$$
READP: SKPINC ;$$ T IFF A CHARACTER HAS BEEN TYPED
JRST FALSE ;$$ (DOES NOT CHECK OLDCH)
JRST TRUE
UNTYI: MOVEI B,-INUM0(A) ;$$ UN-READ A CHARACTER (PUT IT IN OLDCH)
MOVEM B,OLDCH
POPJ P, ;$$ RETURN ARG AS VALUE
PAGE
;output
ITYO: SUBI A,INUM0
PUSHJ P,TYO
JRST FIXI
TYO: CAIG A,CR
JRST TYO3
SOSGE CHCT
JRST TYO1
JRST TYOD
REMOTE<TYOD: JRST TTYO+X ;sosg x for other device
;other device output
JRST TYO2X
TYO5: IDPB A,X
POPJ P,
TYO2X: OUT X,
JRST TYO5
ERR1 [SIXBIT /OUTPUT ERROR!/]>
TYO1: PUSH P,A ;linelength exceeded
MOVEI A,IGCRLF ;inored cr-lf
PUSHJ P,TYOD
PUSHJ P,TERPRI ;force out a cr-lf, with special mark
POP P,A
SOSA CHCT
TYO4: POP P,B
JRST TYOD
TYO3: CAIGE A,TAB
JUMPN A,TYO+2 ;everything between 0(null) and 11(tab) decrement chct
PUSH P,B
MOVE B,LINL
CAIN A,TAB
JRST [ SUB B,CHCT
IORI B,7 ;simulate tab effect on chct
SUB B,LINL
SETCAM B,CHCT
JRST TYO4]
CAIN A,CR
MOVEM B,CHCT ;reset chct after a cr
JRST TYO4
LINELENGTH:
JUMPE A,LINEL1
SUBI A,INUM0
HRRM A,LINL
HRRM A,CHCT
LINEL1: HRRZ A,LINL
JRST FIXI
CHRCT: MOVE A,CHCT
JRST FIXI
REMOTE<
LINL: TTYLL
CHCT: TTYLL>
;teletype output
TTYO: OUTCHR A ;output single character in a
POPJ P,
PAGE
REMOTE<DDTIFG: TRUTH>
DDTIN: EXCH A,DDTIFG
POPJ P,
TTYRET: PUSHJ P,OUTCNT
JRST INCNT
;THIS IS THE NEW, FAST, AND SHORT ROUTINE TO TURN OFF CONTROL O
TTYCLR: SKPINC
CAI
POPJ P,
REMOTE<
TTOCH: 0
IFN STPGAP,<
0 ;tty page number always zero
0 ;tty line number -- always zero
>
TTOLL: TTYLL
TTOHP: TTYLL>
PAGE
SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL --- PAGE 7
;convert ascii to sixbit for device initialization routines
SIXMAK: SETZM SIXMK2#
MOVE AR1,[POINT 6,SIXMK2]
HRROI R,SIXMK1
PUSHJ P,PRINTA ;use print to unpack ascii characters
MOVE A,SIXMK2
POPJ P,
SIXMK1: ADDI A,40
TLNN AR1,770000
POPJ P, ;last character position -- ignore remaining chars
CAIN A,"."+40
MOVEI A,0 ;ignore dots at end of numbers for decimal base
CAIN A,":"+40
HRLI AR1,(POINT 6,0,29) ;deposit : in last char position
IDPB A,AR1
POPJ P,
;subroutine to process next item in file name list
INXTIO: JUMPE T,NXTIO
HRRZ T,(T)
NXTIO: HLRZ A,(T)
PUSHJ P,ATOM
JUMPE A,CPOPJ ;non-atomic
HLRZ A,(T)
JRST SIXMAK ;make sixbit if atomic
;right normalize sixbit
LSH A,-6
SIXRT: TRNN A,77
JRST .-2
POPJ P,
PAGE
IOSUB: PUSHJ P,NXTIO
MOVEM T,DEVDAT#
LDB B,[POINT 6,A,35]
JUMPE A,IOPPN ;non-atomic item, must be ppn or (file.ext)
CAIE B,":"-40
JRST IOFIL ;not a device name -- must be file name
TRZ A,77 ;clear out the :
SETZM PPN
IODEV2: MOVEM A,DEV
PUSHJ P,INXTIO
IOPPN: JUMPN A,IOFIL ;not ppn or (fil.ext)
PUSHJ P,PPNEXT
JUMPN A,IOEXT ;(fil.ext)
HLRZ A,(T)
HLRZ A,(A) ;caar is project number
IFE STANSW,< HRRZI A,-INUM0(A) ;$$ASSUME PROJECT NUMBER IS AN INUM>
IFN STANSW,< PUSHJ P,SIXMAK
PUSHJ P,SIXRT>
HRLM A,PPN ;project number
HLRZ A,(T)
PUSHJ P,CADR ;cadar is programmer number
IFE STANSW,< HRRZI A,-INUM0(A) ;$$ASSUME PROGRAMMER NUMBER IS AN INUM>
IFN STANSW,< PUSHJ P,SIXMAK
PUSHJ P,SIXRT>
HRRM A,PPN ;programmer number
HRLZI A,(SIXBIT /DSK/) ;disk is assumed
JRST IODEV2
IOFIL: SKIPN DEV
JRST AIN.1 ;no device named
JUMPN A,IOFIL2 ;was it an atom
JUMPE T,CPOPJ ;no, was it nil (end)
PUSHJ P,PPNEXT
JUMPE A,CPOPJ ;see a ppn, no file named
IOEXT: HLRZ A,(T) ;(file.ext)
HRRZ A,(A) ;get cdr == extension
PUSHJ P,SIXMAK
HLLM A,EXT
HLRZ A,(T)
HLRZ A,(A) ;get car = file name
PUSHJ P,SIXMAK
FIL: PUSH P,A
PUSHJ P,INXTIO
JRST POPAJ
IOFIL2: CAIN B,":"-40
POPJ P, ;saw a :,not file name
SETZM EXT ;file name -- clear extension
JRST FIL
PPNEXT: JUMPE T,CPOPJ ;end of file name list
HLRZ A,(T)
HRRZ A,(A) ;cdar
JRST ATOM ;ppn iff (not(atom(cdar l)))
CHNSUB: MOVE T,A
HLRZ A,(T)
PUSHJ P,ATOM
JUMPE A,TRUE ;non-atomic head of list -- no channel named
HLRZ A,(T)
PUSHJ P,SIXMAK
ANDI A,77
CAIN A,":"-40
JRST TRUE ;device name, assume channel name t
HLRZ A,(T) ;channel name -- return it
HRRZ T,(T)
POPJ P,
REMOTE<
CHTAB=.-FSTCH
BLOCK NIOCH>
;channel data
CHNAM==0 ;name of channel
CHDEV==1 ;name of device
CHPPN==2 ;ppn for input channel
CHOCH==3 ;oldch for input channels
IFN STPGAP,<
CHPAGE==4 ;page number for input
CHLINE==5 ;line number for input
CHDAT==6 ;device data
POINTR==7 ;byte pointer for device buffer
COUNT==10 ;character count for device buffer
>
IFE STPGAP,<
CHDAT==4
POINTR==5
COUNT==6
>
CHLL==2 ;linelength for output channel
CHHP==3 ;hposit for output channels
PAGE
;search for channel name in chtab
TABSR1: MOVE A,[XWD -NIOCH,FSTCH]
MOVE C,CHTAB(A)
CAME B,CHNAM(C)
AOBJN A,.-2
CAMN B,CHNAM(C)
POPJ P, ;found it!!!
JRST FALSE ;lost
;search for channel name in chtab, and if not there find a free channel, and
;if no free channel, allocate a new buffer and channel
TABSRC: MOVE B,A
PUSHJ P,TABSR1
JUMPN A,DEVCLR ;found the channel
PUSH P,B
MOVE B,0
PUSHJ P,TABSR1 ;find a physical channel no. for a free channel
JUMPE A,[ERR1 [SIXBIT $NO I/O CHANNELS LEFT !$]]
POP P,B
JUMPN C,DEVCLR ;found free channel which had buffer space previously
PUSH P,A ;must allocate new buffer
MOVEI A,BLKSIZ
SETZ D, ;SPECIAL RELOCATION - SEE LOAD
PUSHJ P,MORCOR ;expand core for buffer if necessary
MOVE C,A
POP P,A
HRRM C,CHTAB(A)
DEVCLR: HRRZ C,CHTAB(A)
HRRZM B,CHNAM(C) ;store name
HRRZM A,CHANNEL#
POPJ P,
;subroutine to reset all i/o channels -- used by excise and realloc
IOBRST: HRRZ A,JOBREL
HRLM A,JOBSA
MOVEM A,CORUSE#
MOVEM A,JOBSYM
SETZM CHTAB+FSTCH
MOVE A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
BLT A,CHTAB+NIOCH+FSTCH-1 ;clear channel table
JRST (R)
PAGE
INPUT: PUSHJ P,CHNSUB ;determine channel name
PUSH P,A
PUSHJ P,TABSRC ;get physical channel number
PUSHJ P,SETIN ;init device
JRST POPAJ
SETIN: MOVEM A,CHANNEL
MOVE A,CHDEV(C)
MOVEM A,DEV
MOVE A,CHPPN(C)
MOVEM A,PPN
PUSHJ P,IOSUB ;get device and file name
MOVEM A,LOOKIN ;file name
MOVE A,DEV
CALLI A,DEVCHR
TLNN A,INB
JRST AIN.2 ;not input device
TLNN A,AVLB
JRST AIN.4 ;not available
MOVE A,CHANNEL
DPB A,[POINT 4,ININIT,ACFLD] ;set up channel numbers
DPB A,[POINT 4,INLOOK,ACFLD]
DPB A,[POINT 4,ININBF,ACFLD]
HRRZ B,CHTAB(A)
HRLM T,CHTAB(A) ;save remaining file name list
MOVEI A,CHDAT(B)
MOVEM A,DEV+1 ;pointer to bufdat
JRST ININIT
REMOTE<
ININIT: INIT X,
DEV: X
X
JRST AIN.7 ;cant init
PUSH B,DEV
PUSH B,PPN
INLOOK: LOOKUP X,LOOKIN
JRST AIN.7 ;cant find file
JRST IRET1>
IRET1: PUSH B,[0] ;oldch
IFN STPGAP,<
PUSH B,[0] ;line number
PUSH B,[0] ;page number
>
ADDI B,4
HRRM B,JOBFF
JRST ININBF
REMOTE<
ININBF: INBUF X,NIOB
JRST TRUE
ENTR:
LOOKIN: BLOCK 4
EXT=LOOKIN+1
PPN=LOOKIN+3
>
PAGE
OUTPUT: PUSHJ P,CHNSUB ;get channel name
PUSH P,A
TRO A,400000 ;set bit for output
PUSHJ P,TABSRC ;get physical channel nuber
PUSHJ P,IOSUB ;get device and file name
MOVEM A,ENTR ;file name
SETZM ENTR+2 ;zero creation date
MOVE A,CHANNEL
DPB A,[POINT 4,AOUT2,ACFLD] ;setup channel numbers
DPB A,[POINT 4,OUTENT,ACFLD]
DPB A,[POINT 4,OUTOBF,ACFLD]
HRRZ B,CHTAB(A)
MOVEI A,CHDAT(B)
HRLM A,AOUT3+1
MOVE A,DEV
MOVEM A,AOUT3
CALLI A,DEVCHR
TLNN A,OUTB
JRST AOUT.2 ;not output device
TLNN A,AVLB
JRST AOUT.4 ;not available
JRST AOUT2
REMOTE<
AOUT2: INIT X,
AOUT3: X
X
JRST AOUT.4 ;cant init
PUSH B,DEV
OUTENT: ENTER X,ENTR
JRST OUTERR ;cant enter
JRST ORET1>
ORET1: PUSH B,[LPTLL] ;linelength
PUSH B,[LPTLL] ;chrct
IFE STPGAP,< ADDI B,4>
IFN STPGAP,< ADDI B,6>
HRRM B,JOBFF
XCT OUTOBF
REMOTE<
OUTOBF: OUTBUF X,NIOB
>
JRST POPAJ
OUTERR: PUSHJ P,AIOP
LDB A,[POINT 3,ENTR+1,35]
CAIE A,2
ERR1 [SIXBIT /DIRECTORY FULL !/]
ERR1 [SIXBIT /FILE IS WRITE PROTECTED !/]
PAGE
IOSEL: MOVE C,-1(P)
JUMPE C,CPOPJ ;tty
JUMPE B,IOSELZ ;dont release
DPB C,[POINT 4,RLS,ACFLD]
XCT RLS
REMOTE<
RLS: RELEASE X, ;release channel
>
HRRZS CHTAB(C) ;release channel table entry
MOVEM 0,@CHTAB(C) ;blast channel name
SETZM -1(P)
IOSELZ: HRRZ C,CHTAB(C)
POPJ P,
PAGE
INCNT: MOVEI A,NIL ;(INC NIL T)
MOVEI B,TRUTH(S)
INC: PUSH P,INCH#
PUSHJ P,IOSEL
JUMPN B,INC2 ;released channel
SKIPN C
MOVEI C,TTOCH-CHOCH ;tty deselect
IFN STPGAP,<
MOVEI B,CHOCH(C)
HRLI B,OLDCH
BLT B,CHLINE(C) ;save channel data
>
IFE STPGAP,<
MOVE B,OLDCH
MOVEM B,CHOCH(C)
>
JRST INC2+1
INC2: SETZM INCH ;CLEAR CHANNEL NOW IN CASE OF BREAK
JUMPE A,ITTYRE ;select tty
MOVE B,A
PUSHJ P,TABSR1 ;determine physical channel number
JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
HRRZM A,INCH
DPB A,[POINT 4,TYI2X,ACFLD] ;set up channel numbers
DPB A,[POINT 4,TYI2Y,ACFLD]
DPB A,[POINT 4,TYI2Z,ACFLD]
HRRZ A,CHTAB(A)
MOVEI T,COUNT(A)
HRLI T,(SOSG)
MOVEI B,POINTR(A)
HRRM B,TYI3 ;set up tyi parameters
HRRM B,TYI3A
INC3:
IFN STPGAP,<
MOVSI B,CHOCH(A)
HRRI B,OLDCH
BLT B,LINUM ;restore channel data
>
IFE STPGAP,<
MOVE B,CHOCH(A)
MOVEM B,OLDCH
>
MOVEM T,TYI2
IOEND: POP P,A
JUMPE A,CPOPJ
MOVE A,CHTAB(A) ;get channel name
HRRZ A,(A)
TRZ A,400000 ;clear output bit
POPJ P,
ITTYRE: SETZM INCH
MOVE T,[JRST TTYI] ;reselect tty
MOVEI A,TTOCH-CHOCH
JRST INC3
PAGE
OUTCNT: MOVEI A,0 ;(outc nil t)
MOVEI B,1
OUTC: PUSH P,OUTCH#
PUSHJ P,IOSEL
JUMPN B,OUTC2 ;closed this file
SKIPN C
MOVEI C,TTOLL-CHLL ;tty deselect
MOVE B,CHCT
MOVEM B,CHHP(C) ;save channel data
MOVE B,LINL
MOVEM B,CHLL(C)
JRST OUTC2+1
OUTC2: SETZM OUTCH ;CLEAR CHANNEL NOW IN CASE OF BREAK
JUMPE A,OTTYRE ;return to tty
TRO A,400000 ;set output bit
MOVE B,A
PUSHJ P,TABSR1 ;determine physical channel number
JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
DPB A,[POINT 4,TYO2X,ACFLD] ;set up tyo2 channel numbers
HRRZM A,OUTCH
HRRZ A,CHTAB(A)
MOVEI B,POINTR(A)
HRRM B,TYO5 ;set up tyo2 parameters
MOVEI T,COUNT(A)
HRLI T,(SOSG)
OUTC3: MOVE B,CHLL(A)
MOVEM B,LINL
MOVE B,CHHP(A)
MOVEM B,CHCT
MOVEM T,TYOD
JRST IOEND
OTTYRE: SETZM OUTCH
MOVE T,[JRST TTYO]
MOVEI A,TTOLL-CHLL ;tty reselect
JRST OUTC3
PAGE
AIN.1: PUSHJ P,AIOP
ERR1 [SIXBIT $ILLEGAL I/O ARG!$]
AOUT.2:
AIN.2: PUSHJ P,AIOP
ERR1 [SIXBIT /ILLEGAL DEVICE!/]
AOUT.4:
AIN.4: PUSHJ P,AIOP
ERR1 [SIXBIT /DEVICE NOT AVAILABLE !/]
AIN.7: PUSHJ P,AIOP
ERR1 [SIXBIT /CAN'T FIND FILE - INPUT!/]
AIN.8: SIXBIT /INPUT ERROR!/
AIOP: MOVE A,DEVDAT
JRST EPRINT
SUBTTL PRINT --- PAGE 8
EPRINT: SKIPN ERRSW
POPJ P,
PUSHJ P,ERRIO
PUSHJ P,PRINT
JRST OUTRET
PRINT: MOVEI R,TYO
PUSHJ P,TERPRI
PUSHJ P,PRIN1
XCT " ",CTY
POPJ P,
PRINC: SKIPA R,.+1
PRIN1: HRRZI R,TYO
PUSH P,A
PUSHJ P,PRINTA
JRST POPAJ
PRINTA: PUSH P,A
MOVEI B,PRIN3
SKIPGE R
MOVEI B,PRIN4
HRRM B,PRIN5
PUSHJ P,PATOM
JUMPN A,PRINT1
XCT "(",CTY
PRINT3: HLRZ A,@(P)
PUSHJ P,PRINTA
HRRZ A,@(P)
JUMPE A,PRINT2
MOVEM A,(P)
XCT " ",CTY
PUSHJ P,PATOM
JUMPE A,PRINT3
XCT ".",CTY
XCT " ",CTY
PUSHJ P,PRIN1A
PRINT2: XCT ")",CTY
JRST POPAJ
PRINT1: PUSHJ P,PRIN1A
JRST POPAJ
PAGE
PRIN1A: MOVE A,-1(P)
CAILE A,INUMIN
JRST PRINIC
JUMPE A,PRIN1B
CAIGE A,@GCP1
CAIGE A,@GCPP1
JRST PRINL
PRIN1B: HRRZ A,(A)
JUMPE A,PRINL
HLRZ B,(A)
HRRZ A,(A)
CAIN B,PNAME(S)
JRST PRINN
CAIN B,FIXNUM(S)
JRST PRINI1
CAIN B,FLONUM(S)
JRSTF @[XWD 0,PRINO] ; TURN OFF DIVIDE CHECK AND UNDERFLOW
BPR: JRST PRIN1B ;bignums change here to JRST BPRINT
JRST PRIN1B
PRINL2: MOVEI R,TYO
JRST PRINL1
PRINL: XCT "#",CTY
HRRZ A,-1(P)
PRINL1: MOVEI C,8
JRST PRINI3
PRINI1: SKIPA A,(A)
PRINIC: SUBI A,INUM0
HRRZ C,VBASE(S)
SUBI C,INUM0
JUMPGE A,PRINI2
XCT "-",CTY
MOVNS A
PRINI2: MOVEI B,"."-"0"
HRLM B,(P)
CAIN C,TEN
SKIPE %NOPOINT(S)
JRST .+2
PUSH P,PRINI4
PRINI3: JUMPL A,[ MOVEI B,0 ;case of -2↑35
MOVEI A,1
DIVI A,(C)
JRST .+2]
IDIVI A,0(C)
HRLM B,(P)
SKIPE A
PUSHJ P,.-3
PRINI4: JRST FP7A1
PRINN: HLRZ A,(A)
MOVEI C,2(SP)
PUSHJ P,PNAMU3
PUSH C,[0]
HRLI C,(POINT 7,0,35)
HRRI C,2(SP)
ILDB A,C
JUMPE A,CPOPJ ;special case of null character
CAIN A,DBLQT
JRST PSTR ;string
PRIN2X: LDB B,[POINT 1,CHRTAB(A),1]
JUMPL R,PRIN4 ;never slash
JRST PRIN2(B) ;1 for no slash
PRIN3: SKIPL CHRTAB(A) ;<0 for no slash
PRIN2: XCT "/",CTY
PRIN4: PUSHJ P,(R)
ILDB A,C
JUMPN A,@PRIN5#
POPJ P,
PSTR: MOVS B,(C)
CAIN B,(<ASCII /"/>)
JRST PRIN2X ;special case of /"
PSTR3: SKIPL R ;dont print " if no slashify
PSTR2: PUSHJ P,(R)
ILDB A,C
CAIE A,DBLQT
JUMPN A,PSTR2
JUMPN A,PSTR3
POPJ P,
TERPRI: PUSH P,A
MOVEI A,CR
PUSHJ P,TYO
MOVEI A,LF
PUSHJ P,TYO
JRST POPAJ
CTY: JSA A,TYOI
REMOTE<
TYOI: X
JRST TYOI2>
TYOI2: PUSH P,A
LDB A,[POINT 6,-1(A),ACFLD]
PUSHJ P,(R)
POP P,A
JRA A,(A)
PRINO: MOVE A,(A)
CLEARB B,C
JUMPG A,FP1
JUMPE A,FP3
MOVNS A
XCT "-",CTY
FP1: CAMGE A,FT01
JRST FP4
CAML A,FT8
AOJA B,FP4
FP3: MULI A,400
ASHC B,-243(A)
MOVE A,B
CLEARM FPTEM#
PUSHJ P,FP7
XCT ".",CTY
MOVNI T,8
ADD T,FPTEM
MOVE B,C
FP3A: MOVE A,B
MULI A,TEN
PUSHJ P,FP7B
SKIPE B
AOJL T,FP3A
POPJ P,
FP4: MOVNI C,6
MOVEI TT,0
FP4A: ADDI TT,1(TT)
XCT FCP(B)
TRZA TT,1
FMPR A,@FCP+1(B)
AOJN C,FP4A
PUSH P,TT
MOVNI B,-2(B)
DPB B,[POINT 2,FP4C,34]
PUSHJ P,FP3
MOVEI A,"E"
PUSHJ P,(R)
MOVE A,FP4C#
IORI A,51
PUSHJ P,(R)
POP P,A
FP7: JUMPE A,FP7A1
IDIVI A,TEN
AOS FPTEM
HRLM B,(P)
JUMPE A,FP7A1
PUSHJ P,FP7
FP7A1: HLRE A,(P)
FP7B: ADDI A,"0"
JRST (R)
353473426555 ;1e32
266434157116 ;1e16
FT8: 1.0E8
1.0E4
1.0E2
1.0E1
FT: 1.0E0
026637304365 ;1e-32
113715126246 ;1e-16
146527461671 ;1e-8
163643334273 ;1e-4
172507534122 ;1e-2
FT01: 175631463146 ;1e-1
FT0:
FCP: CAMLE A,FT0(C)
CAMGE A,FT(C)
XWD C,FT0
SUBTTL SUPER FAST TABLE DRIVEN READ 14-MAY-69 PAGE 9
;magic scanner table bit definitions
;bit 0=0 iff slashified as nth id character
;bit 1=0 iff slashified as 1st id character
;bits 2-5 ratab index
;bits 6-8 dotab index
;bits 9-10 strtab index
;bits 11-13 idtab index
;bits 14-16 exptab index
;bits 17-19 rdtab index
;bits 20-25 ascii to radix 50 conversion
REMOTE<
IGSTRT: IGCRLF
IGEND: LF
RATFLD: POINT 4,CHRTAB(A),5
STRFLD: POINT 2,CHRTAB(A),10
IDFLD: POINT 3,CHRTAB(A),13
>
DOTFLD:
NUMFLD: POINT 3,CHRTAB(A),8
EXPFLD: POINT 3,CHRTAB(A),16
RDFLD: POINT 3,CHRTAB(A),19
R50FLD: POINT 6,CHRTAB(A),25
;magic state flags in t
EXP==1 ;exponent
NEXP==2 ;negative exponent
SAWDOT==4 ;saw a dot (.)
MINSGN==10 ;negative number
IDCLS==0 ;identifier
STRCLS==1 ;string
NUMCLS==2 ;number
DELCLS==3 ;delimiter
PAGE
;macros for scanner table
DEFINE RAD50 (X)<
IFB <X>,<R50VAL=0>
IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL="X"-"0"+1>>
IFIDN <"X"><".">,<R50VAL=45>
IFGE <"X"-"A">,<R50VAL="X"-"A"+13>>
DEFINE TABIN (S1,SN,R,D,S,I,E,RD,R50)<
XLIST
IRPC R50< RAD50 (R50)
BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL>
LIST>
DEFINE LET (X)<
TABIN (1,1,5,2,3,4,2,0,X)>
DEFINE DELIMIT (X,Y)<
TABIN (0,0,2,2,3,2,2,Y,X)>
DEFINE IGNORE (X)<
TABIN (0,0,3,2,3,2,2,0,X)>
PAGE
REMOTE<CHRTAB:
TABIN (0,0,1,1,1,1,1,0,< >)
;null
LET (< >)
IGNORE (< >)
;tab,lf,vtab,ff,cr
LET (< >)
;16 to 30
TABIN (0,0,0,0,0,0,0,0,< >)
;igmrk
TABIN (0,0,0,0,0,0,0,0,< >)
;32 THE OLD IGMRK, WILL ALLOW THE CHAR. TO WORK ON READS BUT NOT TYI
LET (< >)
;33 to 37
IGNORE (< >)
;space
LET (< >)
;!
TABIN (0,0,9,2,2,2,2,0,< >)
;"
LET (< $% >)
;#$%&'
DELIMIT (< >,0)
DELIMIT (< >,1)
;()
LET (< >)
;*
TABIN (1,1,14,2,3,4,2,0,< >)
;+
IGNORE (< >)
;,
TABIN (1,1,6,2,3,4,2,0,< >)
;-
TABIN (0,0,7,3,3,2,2,4,<.>)
TABIN (0,0,4,2,3,3,2,0,< >)
;/
TABIN (1,0,8,5,3,4,3,0,<0123456789>)
LET (< >)
;:;<=>?
TABIN (1,0,2,2,3,4,2,5,< >)
;@
LET (<ABCD>)
TABIN (1,1,5,4,3,4,2,0,<E>)
LET (<FGHIJKLMNOPQRSTUVWXYZ>)
DELIMIT (< >,2)
;[
LET (< >)
;\
DELIMIT (< >,3)
;]
LET (< >)
;↑←`
LET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>)
;lower case
LET (< >)
;{¬
DELIMIT (< >,3)
;altmode
LET (< >)
;}
DELIMIT (< >,6)
;rubout
>
PAGE
READCH: PUSHJ P,TYI
MOVSI AR1,AR1
PUSHJ P,EXPL1
JRST CAR
READP1: SETZM NOINFG
READ0: PUSH P,TYI2
PUSH P,OLDCH
SETZM OLDCH#
HRLI A,(JRST)
MOVEM A,TYI2
PUSHJ P,READ+1
POP P,OLDCH
POP P,TYI2
POPJ P,
RDRUB: MOVEI A,CR
PUSHJ P,TTYO
MOVEI A,LF
PUSHJ P,TTYO
SKIPA P,PSAV#
READ: SETZM NOINFG# ;0 means intern
MOVEM P,PSAV
PUSHJ P,READ1
SETZM PSAV
POPJ P,
READ1: PUSHJ P,RATOM
POPJ P, ;atom
XCT RDTAB2(B)
JRST READ1 ;try again
RDTAB2: JRST READ2 ;0 (
JFCL ;1 )
JRST READ4 ;2 [
JFCL ;3 ],$
JFCL ;4 .
JRST RDQT ;5 @
READ2: PUSHJ P,RATOM
JRST READ2A ;atom
XCT RDTAB(B)
READ2A: PUSH P,A
PUSHJ P,READ2
POP P,B
JRST XCONS
RDTAB: PUSHJ P,READ2 ;0 (
JRST FALSE ;1 )
PUSHJ P,READ4 ;2 [
JRST READ5 ;3 ],$
JRST RDT ;4 .
PUSHJ P,RDQT ;5 @
RDTX: PUSHJ P,RATOM
POPJ P, ;atom
XCT RDTAB2(B)
JRST DOTERR ;dot context error
RDT: PUSHJ P,RDTX
PUSH P,A
PUSHJ P,RATOM
JRST DOTERR
CAIN B,1
JRST POPAJ
CAIE B,3
JRST DOTERR
MOVEM A,OLDCH
JRST POPAJ
READ4: PUSHJ P,READ2
MOVE B,OLDCH
CAIE B,ALTMOD
TYI1: SETZM OLDCH ;kill the ]
POPJ P,
READ5: MOVEM A,OLDCH ;save ] or $
JRST FALSE ;and return nil
RDQT: PUSHJ P,READ1
JRST QTIFY
PAGE
;atom parser
COMMENT: PUSHJ P,TYID
CAME A,IGEND
JRST COMMENT
POPJ P,
RATOM: SKIPE SMAC# ;$$ CHECK FOR A SPLICE MACRO LIST
JRST PSMAC ;$$ GET ITEM FROM SPLICE MACRO LIST
SETZB T,R
HRLI C,(POINT 7,0,35)
HRRI C,(SP)
MOVEM C,ORGSTK# ;SAVE FOR BACKING UP ON + AND -
MOVEI AR1,1
RATOM2: PUSHJ P,TYIA
LDB B,RATFLD
JRST RATAB(B)
RATAB: PUSHJ P,COMMENT ;0 comment
JRST RATOM2 ;1 null
JRST RATOM3 ;2 delimit
JRST RATOM2 ;3 ignore
PUSHJ P,TYI ;4 /
JRST RDID ;5 letter
JRST RDNMIN ;6 -
JRST RDOT ;7 .
JRST RDNUM ;8 digit
JRST RDSTR ;9 string
JRST RMACRO ;10 MACRO
JRST SMACRO ;11 SPLICE MACRO
JRST RDNPLS ;12 +
;a real dotted pair
RDOT2: MOVEM A,OLDCH
MOVE A,ORGSGN ;ORGSGN NORMALLY CONTAINS A "." AT THIS POINT
RATOM3: LDB B,RDFLD
HRRI R,DELCLS ;delimiter
AOS (P) ;non-atom (ie a delimiter)
POPJ P,
;dot handler
RDOT: MOVEM A,ORGSGN ;INCASE SOMETHING ELSE DEFINED AS "."
PUSHJ P,TYID
LDB B,DOTFLD
JRST DOTAB(B)
DOTAB: PUSHJ P,COMMENT ;0 comment
JRST RDOT+1 ;1 null
JRST RDOT2 ;2 delimit
JRST RDOT2 ;3 dot
JRST RDOT2 ;4 e
MOVEI B,0 ;5 digit
IDPB B,C
TLO T,SAWDOT
JRST RDNUM
PAGE
;string scanner
STRTAB: PUSHJ P,COMMENT ;0 comment
JRST RDSTR+1 ;1 null
JRST STR2 ;2 delimit
RDSTR: IDPB A,C ;3 string element
PUSHJ P,TYID
LDB B,STRFLD
JRST STRTAB(B)
STR2: MOVEI A,DBLQT
HRRI R,STRCLS ;string
IDPB A,C
NOINTR: PUSHJ P,IDEND ;no intern
PUSHJ P,IDSUB
JRST PNAMAK
;identifier scanner
IDTAB: PUSHJ P,COMMENT ;0
JRST RDID+1 ;1 null
JRST MAKID ;2 delimit
PUSHJ P,TYI ;3 /
RDID: IDPB A,C ;4 letter or digit
PUSHJ P,TYID
LDB B,IDFLD
JRST IDTAB(B)
PAGE
;LINEREAD - RETURNS ALL THE EXPRESSIONS ON ONE LINE AS A LIST
;
LINRD: PUSHJ P,READ
HRRZ B,A
SKIPE SMAC ;CHECK THE SPLICE LIST
JRST LRMORE
SKIPN A,OLDCH
LRTY: PUSHJ P,TYID ;NEED A CHARACTER
MOVEM A,OLDCH ;SAVE IT
LDB C,RATFLD ;THIS KLUDGE IS TO AVOID MAKING ANOTHER TABLE ENTRY
CAIN C,7 ;SPECIAL CHECK FOR "."
JRST LRTY1 ;IGNORE IT
CAILE C,3 ;ELIMINATE MOST POSSIBILITIES
JRST LRMORE ;MORE ON THE LINE
JUMPE C,LREND ;END LINE ON COMMENT - THINK ABOUT IT, ITS RIGHT
LDB C,RDFLD
JRST LR1(C)
LR1: JRST LPIG ;0 MORE TO FIGURE OUT
JRST LRTY1 ;1 IGNORE
JRST LRMORE ;2 MORE ON THE LINE
SUBI A,ALTMOD ;3 CHECK ALTMOD
JUMPN A,LRTY1 ;4 IGNORE "]" AND "."
JUMPN A,LRMORE ;5 MORE ON "@"
JRST LREND
LPIG: CAIN A,"(" ;THESE SPECIAL CHECK COULD SCREW UP READ MACROS
JRST LRMORE
CAIE A,TAB
CAIL A,40 ;READ MORE IF SPACE, COMMA, OR TAB
JRST [ HRLI B,-1 ;SET SPQCE FLAG AND TRY AGAIN
JRST LRTY]
CAIE A,CR ;ALWAYS IGNORE CR.S
TLZE B,-1 ;EOL - IF SPACE FLAG THEN DO A PEEKC
JRST LRTY
LREND: HRRZ A,B ;FINALLY GOT THERE
JRST NCONS
LRMORE: HRLI B,0
PUSH P,B ;MORE TO GO, PUSH
PUSHJ P,LINRD ;AND CALL YOURSELF
POP P,B
JRST XCONS
LRTY1: HRLI B,0 ;CLEAR SPACE FLAG
JRST LRTY
PAGE
;NEW AND SUBER BITCHEN READ MACROS
;
RMACRO:
IFN ALVINE,<
SKIPE PSAV1 ;$$ ARE WE IN ALVINE?
JRST RATOM2 ;$$ YES, IGNORE>
RMAC2: IDPB A,C ;$$ CONVERT THE CHAR. TO AN ATOM
PUSHJ P,IDEND ;$$
PUSHJ P,INTER0 ;$$
MOVEM A,T ;$$ SAVE ATOM IN CASE OF ERROR
MOVEI B,READMACRO(S) ;$$ GET THE FUNCTION NAME
PUSHJ P,GET ;$$
JUMPE A,RMERR ;$$ UNDEFINED READ MACRO
PUSHJ P,NCONS ;$$ CONVERT TO A FORM
PUSH P,PSAV ;$$
PUSHJ P,EVAL ;$$ EVALUATE THE FORM
POP P,PSAV ;$$
POPJ P, ;$$ RETURN
;SPECIAL PROCESSING OF SPLICE MACROS
SMACRO:
IFN ALVINE,<
SKIPE PSAV1 ;$$ ARE WE IN ALVINE?
JRST RATOM2 ;$$ YES, IGNORE>
PUSHJ P,RMAC2 ;$$ EVALUATE THE MACRO
MOVEM A,SMAC ;$$ SAVE THE SPLICE LIST
JRST RATOM ;$$ START OVER
;GET AN ITEM OFF OF THE SPLICE LIST
PSMAC: MOVE A,SMAC ;$$
PUSHJ P,ATOM ;$$ IS SPLICE LIST AN ATOM?
JUMPN A,[ MOVE A,SMAC ;$$ YES, SIMULATE . <ATOM>
PUSHJ P,NCONS ;$$
MOVEM A,SMAC ;$$
MOVEI B,4 ;$$
JRST RATOM3+1] ;$$
MOVE B,@SMAC ;$$
HLRZ A,B ;$$ RETURN NEXT ITEM OF SPLICE LIST
HRRZM B,SMAC ;$$ ADVANCE SPLICE LIST
POPJ P, ;$$ RETURN
PAGE
;number scanner
NUMTAB: PUSHJ P,COMMENT ;0 comment
JRST RDNUM+1 ;1 null
JRST NUMAK ;2 delimit
JRST RDNDOT ;3 dot
JRST RDE ;4 e
RDNUM: IDPB A,C ;5 digit
PUSHJ P,TYID
LDB B,NUMFLD
JRST NUMTAB(B)
RDNDOT: TLOE T,SAWDOT
JRST NUMAK ;two dots - delimit
MOVEI A,0
JRST RDNUM
RDNMIN: TLO T,MINSGN
RDNPLS: MOVEM A,ORGSGN# ;SAVE SIGN IN CASE OF BACKUP
JRST RDNUM+1
;exponent scanner
RDE: CAME C,ORGSTK ;FOR +E AND -E TYPE OF ATOMS
JRST .+3
MOVEM A,OLDCH
JRST KLDG1
TLO T,EXP
MOVEI A,0
IDPB A,C
PUSHJ P,TYID
CAIN A,"-"
TLOA T,NEXP
CAIN A,"+"
JRST RDE2+1
JRST RDE2+2
EXPTAB: PUSHJ P,COMMENT ;0
JRST RDE2+1 ;1 null
JRST NUMAK ;2 delimit
RDE2: IDPB A,C ;3 digit
PUSHJ P,TYID
LDB B,EXPFLD
JRST EXPTAB(B)
PAGE
;semantic routines
;identifier interner and builder
IDEND: TDZA A,A
IDEND1: IDPB A,C
TLNE C,760000
JRST IDEND1
POPJ P,
MAKID: MOVEM A,OLDCH
PUSHJ P,IDEND
SKIPE NOINFG
JRST NOINTR ;dont intern it
INTER0: PUSHJ P,IDSUB
PUSHJ P,INTER1 ;is it in oblist
POPJ P, ;found
PUSHJ P,PNAMAK ;not there
MAKID2: MOVE C,CURBUC# ;
HLRZ B,@RHX2
PUSHJ P,CONS ;cons it into the oblist
HRLM A,@RHX2
JRST CAR
;pname unmaker
PNAMUK:
MOVEI B,PNAME(S)
PUSHJ P,GET
JUMPE A,NOPNAM
MOVE C,SP
PNAMU3: HLRZ B,(A)
PUSH C,(B)
HRRZ A,(A)
JUMPN A,PNAMU3
POPJ P,
;idsub constructs a iowd pointer for a print name
IDSUB: HRRZS C
CAML C,JRELO ;top of spec pdl
JRST SPDLOV
MOVNS C
ADDI C,(SP)
HRLI C,1(SP)
MOVSM C,IDPTR#
POPJ P,
PAGE ;identifier interner
INTER1: MOVE B,1(SP) ;get first word of pname
LSH B,-1 ;right justify it
IDIV B,INT1 ;compute hash code
REMOTE<
INT1: BCKETS
RHX2:
XXX1: XWD B+1,OBTBL>
HLRZ TT,@RHX2 ;get bucket
MOVEM B+1,CURBUC ;save bucket number
MOVE T,TT
JRST MAKID1
MAKID3: MOVE TT,T ;save previous atom
HRRZ T,(T) ;get next atom
MAKID1: JUMPE T,CPOPJ1 ;not in oblist
HLRZ A,(T) ;next id in oblist
MAKID4: HRRZ A,(A)
JUMPE A,NOPNAM ;no print name
MOVE A,(A)
HLRZ C,A
CAIE C,PNAME(S)
JRST MAKID4
MOVE C,IDPTR ;found pname
HLRZ A,(A)
MAKID5: JUMPE A,MAKID3 ;not the one
MOVS A,(A)
MOVE B,(A)
ANDCAM AR1,(C) ;clear low bit
CAME B,(C)
JRST MAKID3 ;not the one
HLRZ A,A ;ok so far
AOBJN C,MAKID5
JUMPN A,MAKID3 ;not the one
HLRZ A,(T) ;this is it
HLRZ B,(TT)
HRLM A,(TT)
HRLM B,(T)
POPJ P,
;pname builder
PNAMAK: MOVE T,IDPTR
PUSHJ P,NCONS
MOVE TT,A
MOVE C,A
PNAMB: MOVE A,(T)
TRZ A,1 ;clear low bit!!!!!
PUSHJ P,FWCONS
PUSHJ P,NCONS
HRRM A,(TT)
MOVE TT,A
AOBJN T,PNAMB
MOVE A,C
HRLZS (A)
JRST PNGNK1+1
PAGE
;number builder
NUMAK: MOVEM A,OLDCH
HRRI R,NUMCLS ;number
CAME C,ORGSTK ;BIG KLUDGE FOR + AND -
JRST .+5
KLDG1: MOVE A,ORGSGN ;ENTER HERE TO BACK UP IN THE CASE OF +E OR -E
IDPB A,C
PUSHJ P,TYIA
JRST RDID+2
MOVEI A,0
IDPB A,C
IDPB A,C
HRRZS C
CAML C,JRELO ;top of spec pdl
JRST SPDLOV
MOVSI C,(POINT 7,0,35)
HRRI C,(SP)
TLNE T,SAWDOT+EXP
JRST NUMAK2 ;decimal number or flt pt
MOVE A,VIBASE(S) ;ibase integrer
SUBI A,INUM0
PUSHJ P,NUM
NUMAK4:
MOVEI B,FIXNUM(S)
NUMAK6: TLNE T,MINSGN
MOVNS A
JRST MAKNUM
NUMAK2: PUSHJ P,NUM10
MOVEM A,TT
TLNN T,SAWDOT
JRST [ PUSHJ P,FLOAT ;flt pt without fraction
MOVE TT,A
JRST NUMAK3]
PUSHJ P,NUM10 ;fraction part
EXCH A,TT
TLNN T,EXP
JUMPE AR2A,NUMAK4 ;no exponent and no fraction
PUSHJ P,FLOAT
EXCH A,TT
PUSHJ P,FLOAT
MOVEI AR1,FT01
PUSHJ P,FLOSUB
FMPR A,B
FADRM A,TT
NUMAK3: PUSHJ P,NUM10 ;exponent part
MOVE AR2A,A
MOVEI AR1,FT-1
TLNE T,NEXP
MOVEI AR1,FT01 ;-exponent
PUSHJ P,FLOSUB
FMPR TT,B ;positive exponent
MOVEI B,FLONUM(S)
MOVE A,TT
JFCL 10,FLOOV
JRST NUMAK6
FLOSUB: MOVSI B,(1.0)
TRZE AR2A,1
FMPR B,(AR1)
JUMPE AR2A,CPOPJ
LSH AR2A,-1
SOJA AR1,FLOSUB+1
;variable radix integer builder
NUM10: MOVEI A,TEN
NUM: HRRM A,NUM1
JFCL 10,.+1 ;clear carry0 flag
SETZB A,AR2A
NUM2: ILDB B,C
JUMPE B,CPOPJ ;done
IMUL A,NUM1#
ADDI A,-"0"(B)
NUM3: JFCL 10,FIXOV ;bignums change this to jfcl 10,rdbnm
AOJA AR2A,NUM2
PAGE
INTERN: MOVEM A,AR2A
PUSHJ P,PNAMUK
PUSHJ P,IDSUB
MOVEI AR1,1
PUSHJ P,INTER1 ;is it in oblist
POPJ P, ;found it
MOVE A,AR2A ;not there
JRST MAKID2 ;put it there
REMOB: JUMPE A,FALSE
MOVEI AR1,1
PUSH P,A
HLRZ A,(A)
PUSHJ P,INTERN
HLRZ B,@(P)
CAME A,B
JRST REMOB2
HRRZ B,CURBUC
REMOTE<
RHX5:
XXX2: XWD B,OBTBL>
HLRZ C,@RHX5
HLRZ T,(C)
CAMN T,A
JRST [ HRRZ TT,(C)
HRLM TT,@RHX5
JRST REMOB2]
REMOB3: MOVE TT,C
HRRZ C,(C)
HLRZ T,(C)
CAME T,A
JRST REMOB3
HRRZ T,(C)
HRRM T,(TT)
REMOB2: POP P,A
HRRZ A,(A)
JRST REMOB
PAGE
;ROUTINE TO ALLOW ARBITRARY MODIFICATION AND READING OF THE
;READ CHARACTER-TABLE BY LISP FUNCTIONS
;TAKES TWO ARGUMENTS A,B
; IF B = NIL IT RETURNS THE CONTENTS OF CHARACTER TABLE
; LOCATION SPECIFIED BY A
; OTHERWISE IT CHANGES THE CHARACTER TABLE ENTRY SPECIFIED BY A
; TO THE BIT PATTERN SPECIFIED BY B, AND RETURNS THE
; PREVIOUS VALUE
MODCHR: PUSH P,B ;$$SAVE BIT PATTERN FOR TABLE
PUSHJ P,NUMVAL ;$$GET POSITION IN TABLE
POP P,B ;$$
MOVE T,CHRTAB(A) ;$$GET OLD TABLE VALUE
JUMPE B,MCEXIT ;$$IF B=NIL THEN JUST RETURN OLD TABLE VALUE
PUSH P,A ;$$SAVE TABLE POSITION
MOVEI A,(B) ;$$
PUSHJ P,NUMVAL ;$$GET NEW BIT PATTERN
POP P,B ;$$GET TABLE POSITION
MOVEM A,CHRTAB(B) ;$$CHANGE TABLE
MCEXIT: MOVE A,T ;$$RETURN OLD TABLE VALUE
JRST FIX1A ;$$CONVERT TO BINARY AND EXIT
;FUNCTION TO DETERMINE THE ASCII VALUE OF A CHARACTER
; CHRVAL TAKES AN ATOM AS ITS ARGUMENT AND USES THE FIRST
; CHARACTER OF THE PRINT NAME
CHRVAL: MOVEI B,PNAME(S) ;$$ GET PRINT NAME
PUSHJ P,GET ;$$
HLRZ A,(A) ;$$
MOVE A,(A) ;$$ FIRST WORD OF PRINT NAME
LSH A,-35 ;$$ SHIFT TO GET FIRST CHARACTER
JRST FIX1A ;$$ CONVERT TO INTEGER
;FUNCTION TO SET BITS FOR A READ MACRO
; A IS THE CHAR. ATOM AND B ARE THE STATUS BITS,
; IF B=NIL NO MODIFICATION IS MADE
; THE OLD STATUS BITS ARE RETURNED
SETCHR: MOVE TT,B ;$$
PUSHJ P,CHRVAL ;$$ CONVERT CHAR. TO INUM
MOVEI B,-INUM0(A) ;$$ CONVERT INUM TO BINARY
LDB A,[POINT 5,CHRTAB(B),5] ;$$ LOAD OLD BITS
JUMPE TT,FIX1A ;$$ NO CHANGE IF B = NIL
MOVEI TT,-INUM0(TT) ;$$ CONVERT STATUS TO BINARY
DPB TT,[POINT 5,CHRTAB(B),5] ;$$ SET NEW BITS
JRST FIX1A ;$$ RETURN
SUBTTL LISP INTERPRETER SUBROUTINES --- PAGE 10
PAGE
CADDDR: SKIPA A,(A)
CADDAR: HLRZ A,(A)
CADDR: SKIPA A,(A)
CADAR: HLRZ A,(A)
CADR: SKIPA A,(A)
CAAR: HLRZ A,(A)
CAR: HLRZ A,(A)
POPJ P,
CDDDDR: SKIPA A,(A)
CDDDAR: HLRZ A,(A)
CDDDR: SKIPA A,(A)
CDDAR: HLRZ A,(A)
CDDR: SKIPA A,(A)
CDAR: HLRZ A,(A)
CDR: HRRZ A,(A)
POPJ P,
CAADDR: SKIPA A,(A)
CAADAR: HLRZ A,(A)
CAADR: SKIPA A,(A)
CAAAR: HLRZ A,(A)
JRST CAAR
CDADDR: SKIPA A,(A)
CDADAR: HLRZ A,(A)
CDADR: SKIPA A,(A)
CDAAR: HLRZ A,(A)
JRST CDAR
CAAADR: SKIPA A,(A)
CAAAAR: HLRZ A,(A)
JRST CAAAR
CDDADR: SKIPA A,(A)
CDDAAR: HLRZ A,(A)
JRST CDDAR
CDAADR: SKIPA A,(A)
CDAAAR: HLRZ A,(A)
JRST CDAAR
CADADR: SKIPA A,(A)
CADAAR: HLRZ A,(A)
JRST CADAR
PAGE
QUOTE: HLRZ A,(A) ;car and quote duplicated for backtrace
POPJ P,
AASCII: PUSHJ P,NUMVAL
LSH A,↑D29
PUSHJ P,FWCONS
PUSHJ P,NCONS
PNGNK1: PUSHJ P,NCONS
MOVEI B,PNAME(S)
PUSHJ P,XCONS
ACONS: TROA B,-1
NCONS: TRZA B,-1
XCONS: EXCH B,A
CONS: AOS CONSVAL
HRL B,A
SKIPN A,F
JRST [ HLR A,B
PUSHJ P,AGC
JRST .-1]
MOVE F,(F)
MOVEM B,(A)
POPJ P,
;new consing routines-not finished yet
;acons: troa b,-1
;ncons: trz b,-1
;cons: exch b,a
;xcons: hrl a,b
; exch a,(f)
; exch a,f
; popj p,
CONSP: CAILE A,INUMIN
JRST FALSE
HLLE A,(A)
AOJE A,FALSE
JRST TRUE
PATOM: CAIL A,@GCP1
JRST TRUE
CAIL A,@GCPP1
ATOM: CAILE A,INUMIN
JRST TRUE
HLLE A,(A)
AOJE A,TRUE
JRST FALSE
PAGE
NEQ: CAMN A,B
JRST FALSE
JRST TRUE
EQ: CAMN A,B
JRST TRUE
JRST FALSE
LENGTH: MOVEI B,0
LNGTH1: CAILE A,INUMIN
JRST FIX1
HLLE C,(A)
AOJE C,FIX1
HRRZ A,(A)
AOJA B,LNGTH1
LAST: HRRZ B,(A)
CAILE B,INUMIN
POPJ P,
HLLE B,(B)
AOJE B,CPOPJ
HRRZ A,(A)
JRST LAST
;(LITATOM X) = (AND (ATOM X) (NOT (NUMBERP X)))
LITATOM:MOVE B,A
PUSHJ P,ATOM
JUMPE A,CPOPJ
MOVE A,B
PUSHJ P,NUMBERP
JRST NOT
PAGE
;NEW RPLACD AND RPLACA WHICH CHECK SO AS NOT TO CLOBBER NIL AND ATOMS
RPLACA: CAILE A,INUMIN ;$$
JRST RPAERR ;$$ ATTEMPT TO RPLACA A SMALL NUMBER
HLL A,(A) ;$$TEST FOR OTHER ATOMS
TLC A,-1 ;$$
TLZN A,-1 ;$$ATOM CARS ARE -1
JRST RPAERR ;$$ATTEMPT TO RPLACA AN ATOM
HRLM B,(A) ;$$STANDARD CODE FOR RPLACA
POPJ P, ;$$
RPLACD: CAIG A,INUMIN ;$$CHECK FOR SMALL BER
JUMPN A,.+2 ;$$CHECK FOR NIL
JRST RPDERR ;$$ATTEMPT TO RPLACD NIL OR A SMALL NUMBER
HRRM B,(A) ;$$OLD RPLACD CODE
POPJ P, ;$$
ZEROP: PUSHJ P,NUMVAL
NOT:
NULL: JUMPN A,FALSE
TRUE:
MOVEI A,TRUTH(S)
POPJ P,
FW0CNS: MOVEI A,0
FWCONS: JUMPN FF,FWC1
EXCH A,FWC0#
PUSHJ P,AGC
EXCH A,FWC0
FWC1: EXCH A,(FF)
EXCH A,FF
POPJ P,
PAGE
SASSOC: PUSHJ P,SAS1
JCALLF 0,(C)
POPJ P,
SAS0: HLRZ B,T
SAS1: JUMPE B,CPOPJ
MOVS T,(B)
MOVS TT,(T)
CAIE A,(TT)
JRST SAS0
HRRZ A,T
CPOPJ1: AOS (P)
POPJ P,
ASSOC: PUSHJ P,SAS1
FALSE: MOVEI A,NIL
CPOPJ: POPJ P,
REVERSE: MOVE T,A
MOVEI A,0
JUMPE T,CPOPJ
HLRZ B,(T)
HRRZ T,(T)
PUSHJ P,XCONS
JUMPN T,.-3
POPJ P,
REMPROP: HRRZ T,(A)
MOVS TT,(T)
CAIN B,(TT)
JRA TT,REMP1
HLRZ A,TT
HRRZ T,(A)
JUMPN T,REMPROP+1
JRST FALSE
REMP1: HRRM TT,(A)
JRST TRUE
PAGE
GET: HRRZ A,(A)
MOVS D,(A)
CAIN B,(D)
JRST CADR
HLRZ A,D
HRRZ A,(A)
JUMPN A,GET+1
POPJ P,
GETL: JUMPE B,FALSE ;$$ NIL LIST - NIL ANSWER
HRRZ A,(A)
GETL0: HLRZ T,(A)
MOVE C,B
GETL1: MOVS TT,(C)
CAIN T,(TT)
POPJ P,
HLRZ C,TT
JUMPN C,GETL1
HRRZ A,(A)
HRRZ A,(A)
JUMPN A,GETL0
POPJ P,
NUMBERP: CAILE A,INUMIN
JRST TRUE
HLLE T,(A)
AOJN T,FALSE
HRRZ A,(A)
HLRZ A,(A)
CAIE A,FIXNUM(S)
CAIN A,FLONUM(S)
JRST TRUE
NUMBP2: JRST FALSE ;bignums change this to JRST BIGNP
STRINGP: MOVE B,A ;= T IF A IS A STRING
PUSHJ P,ATOM
JUMPE A,CPOPJ
MOVE A,B
PUSHJ P,NUMBERP ;MUST NO BE A NUMBER
JUMPN A,FALSE
MOVE A,B
PUSHJ P,CHRVAL ;GET THE FIRST CHARACTER
CAIE A,42+INUM0 ;CHECK FOR "
JRST FALSE
JRST TRUE
PAGE
PUTPROP: MOVE T,A
HRRZ A,(A)
CSET3: MOVS TT,(A)
HLRZ A,TT
CAIN C,(TT)
JRST CSET2
HRRZ A,(A)
JUMPN A,CSET3
HRRZ A,(T)
PUSHJ P,XCONS
HRRZ B,C
PUSHJ P,XCONS
HRRM A,(T)
JRST CADR
CSET2:
CAIE C,VALUE(S)
JRST CSET1
HRRZ T,(B)
HLRZ A,(A)
HRRM T,(A)
JRST PROG2
CSET1: HRLM B,(A)
PROG2: MOVE A,B
PROG1: POPJ P,
DEFPROP:
HRRZ B,(A)
HRRZ C,(B)
HLRZ A,(A)
HLRZ B,(B)
HLRZ C,(C)
PUSH P,A
PUSHJ P,PUTPROP
JRST POPAJ
PAGE
EQUAL: MOVE C,P
EQUAL1: CAMN A,B
JRST TRUE
MOVE T,A
MOVE TT,B
PUSHJ P,ATOM
EXCH A,B
PUSHJ P,ATOM
CAMN A,B
JRST EQUAL3
EQUAL4: MOVE P,C
JRST FALSE
EQUAL3: JUMPN A,EQ2
PUSH P,T
PUSH P,TT
HLRZ A,(T)
HLRZ B,(TT)
PUSHJ P,EQUAL1
JUMPE A,EQUAL4
POP P,B
POP P,A
HRRZ A,(A)
HRRZ B,(B)
JRST EQUAL1
EQ2: PUSH P,T
MOVE A,T
PUSHJ P,NUMBERP
JUMPE A,EQUAL4
MOVE A,TT
PUSHJ P,NUMBERP
JUMPE A,EQUAL4
MOVE A,(P)
MOVEM C,(P)
MOVE B,TT
JSP C,OP
JUMPL COMP3
JUMPL COMP3
COMP3: POP P,C
CAME A,TT
JRST EQUAL4
JRST TRUE
PAGE
SUBS5: HRRZ A,SUBAS
POPJ P,
SUBST: MOVEM A,SUBAS#
MOVEM B,SUBBS#
SUBS0A: MOVE A,SUBAS
MOVE B,SUBBS
PUSH P,C
MOVE A,C
PUSHJ P,EQUAL
POP P,C
JUMPN A,SUBS5
CAILE C,INUMIN
JRST EV6A
HLLE T,(C)
AOJN T,SUBS2
EV6A: MOVE A,C
POPJ P,
SUBS2: PUSH P,C
HLRZ C,(C)
PUSHJ P,SUBS0A
EXCH A,(P)
HRRZ C,(A)
PUSHJ P,SUBS0A
POP P,B
JRST XCONS
COPY: MOVEI B,INUM0 ;$$ (SUBST 0 0 A)
MOVEI C,INUM0
EXCH A,C
JRST SUBST
; NTHCHAR = THE BTH CHARACTER OF A.
NTHCHAR:MOVE T,B
SUBI T,INUM0
JUMPE T,FALSE ;FAIL IF = 0
PUSH P,A
MOVEM T,ORGSGN
JUMPG T,NTH3
PUSHJ P,%FLATSIZEC
MOVEI T,1-INUM0(A)
ADDB T,ORGSGN
NTH3: MOVE A,(P)
PUSHJ P,LITATOM
JUMPN A,NTH4
POP P,A
HRROI R,NTH5 ;I HOPE THIS IS RIGHT
PUSHJ P,PRINTA
HLRZ A,ORGSGN
JRST NTH6
NTH5: SOSN ORGSGN
HRLOM A,ORGSGN
POPJ P,
NTH4: MOVE T,ORGSGN
POP P,A
MOVEI B,PNAME(S)
PUSHJ P,GET
JUMPE A,CPOPJ ;FAIL IF NO PRINT NAME
NTH1: CAIG T,5
JRST NTH2
HRRZ A,(A)
JUMPE A,FALSE ;FAIL IF NO NTH CHARACTER
SUBI T,5
JRST NTH1
NTH2: HLRZ A,(A)
IMULI T,-7
LSH T,14
ADDI T,440700
HRL A,T
LDB A,A
JUMPE A,FALSE
NTH6: PUSHJ P,AASCII+1 ;CONVERT TO AN ATOM
JRST INTERN ;INTERN IT
PAGE
NCONC: TDZA R,R
APPEND: MOVEI R,.APPEND-.NCONC
JUMPE T,FALSE
POP P,B
APP2: AOJE T,PROG2
POP P,A
PUSHJ P,.NCONC(R)
MOVE B,A
JRST APP2
.NCONC: JUMPE A,PROG2
MOVE TT,A
MOVE C,TT
HRRZ TT,(C)
JUMPN TT,.-2
HRRM B,(C)
POPJ P,
.APPEND: JUMPE A,PROG2
MOVEI C,AR1
MOVE TT,A
APP1: HLRZ A,(TT)
PUSH P,B
PUSHJ P,CONS ;saves b
POP P,B
HRRM A,(C)
MOVE C,A
HRRZ TT,(TT)
JUMPN TT,APP1
JRST SUBS4
PAGE
MEMBER: MOVEM A,SUBAS
MEMB1: JUMPE B,FALSE
MOVEM B,SUBBS
MOVE A,SUBAS
HLRZ B,(B)
PUSHJ P,EQUAL
JUMPN A,CPOPJ
MOVE B,SUBBS
HRRZ B,(B)
JRST MEMB1
MEMQ: JUMPE B,FALSE
MOVS C,(B)
CAIN A,(C)
JRST TRUE
HLRZ B,C
JUMPN B,MEMQ+1
JRST FALSE
;NEW MEM-FUNCTIONS THAT RETURN THE TAIL OF THE LIST STARTING WHERE
; THE ELEMENT IS FOUND
MEMBR.: PUSHJ P,MEMBER
SKIPE A
MOVE A,SUBBS
POPJ P,
MEMB: PUSHJ P,MEMQ
SKIPE A
MOVE A,B
POPJ P,
;NEW AND AND OR FUNCTIONS (AND#, OR#) THAT RETURN THE EXPRESSION
; THAT CAUSED THE FUNCTION TO EVALUATE TO TRUE
AND.: PUSHJ P,AND
SKIPA
OR.: PUSHJ P,OR
HRRZ A,2(P)
POPJ P,
AND:
HRLI A,TRUTH(S)
OR: HLRZ C,A
PUSH P,C
ANDOR: HRRZ C,A
JUMPE C,AOEND
MOVSI C,(SKIPE (P))
TLNE A,-1
MOVSI C,(SKIPN (P))
XCT C
JRST AOEND
MOVEM A,(P)
HLRZ A,(A)
PUSHJ P,EVAL
EXCH A,(P)
HRR A,(A)
JRST ANDOR
AOEND: POP P,A
SKIPE A
MOVEI A,TRUTH(S)
POPJ P,
GENSYM: MOVE B,[POINT 7,GNUM,34]
MOVNI C,4
MOVEI TT,"0"
GENSY2: LDB T,B
AOS T
DPB T,B
CAIG T,"9"
JRST GENSY1
DPB TT,B
ADD B,[XWD 70000,0]
AOJN C,GENSY2
GENSY1: MOVE A,GNUM
PUSHJ P,FWCONS
PUSHJ P,NCONS
JRST PNGNK1
REMOTE<
GNUM: ASCII /G0000/>
CSYM: HLRZ A,(A)
PUSH P,A
MOVEI B,PNAME(S)
PUSHJ P,GET
JUMPE A,NOPNAM
HLRZ A,(A)
MOVE A,(A)
MOVEM A,GNUM
JRST POPAJ
PAGE
LIST: MOVEI B,CEVAL(S)
PUSH P,B
PUSH P,A
MOVNI T,2
JRST MAPCAR
EELS: HLRZ TT,(T) ;interpret lsubr call
HRRZ A,(AR1)
ILIST: MOVEI T,0
JUMPE A,ILIST2
ILIST1: PUSH P,A
HLRZ A,(A)
PUSH P,TT
HRLM T,(P)
PUSH P,SP ;$$SAVE SP POINTER TO RESTORE AFTER ARGUMENT EVALUATED
PUSHJ P,EVAL ;EVALUATE ARGUMENT
POP P,SP ;$$RESTORE SP POINTER AFTER EVAL
ILIST3: POP P,TT
HLRE T,TT
EXCH A,(P)
HRRZ A,(A)
SOS T
JUMPN A,ILIST1
ILIST2: JRST (TT)
;FAST MAPC FOR 2 ARGS - CALLED BY LAP CODE ONLY
.MAPC: PUSH P,A
JUMPE B,PRETB
HLRZ A,(B)
HRRZ B,(B)
PUSH P,B
CALLF 1,@-1(P)
POP P,B
JRST .MAPC+1
;FAST MAP FOR 2 ARGS - CALLED BY LAP CODE ONLY
.MAP: PUSH P,A
JUMPE B,PRETB
MOVE A,B
HRRZ B,(B)
PUSH P,B
CALLF 1,@-1(P)
POP P,B
JRST .MAP+1
PRETB: SUB P,[XWD 1,1]
JRST PROG2
PAGE
; NEW AND SUPER POWERFUL MAP FUNCTIONS
MAPCON: TLZ T,100000
JRST MAPLIST
MAPCAN: TLZA T,100000
MAPC: TLZA T,400000
MAPCAR: TLZA T,400000
MAP: TLZ T,200000
; INITIALIZE
MAPLIST:SETCA T,T
MOVEI A,(CALLF)
DPB T,[POINT 4,A,30]
MOVE B,P
MOVE AR1,T
HRL AR1,T
SUB B,AR1
PUSH P,B
HRLM A,(B)
PUSH P,T
PUSH P,
HRLZM P,(P)
; SET UP TO GET ARGUMENTS
MAPL2: HRRZ T,-1(P)
MOVEI TT,-3(P)
; MOVE ARGS TO REGS
MPL3: MOVE D,(TT)
JUMPE D,MPDN
MOVEM D,(T)
MOVE D,(D)
SKIPGE -1(P)
HLRZM D,(T)
HRRZM D,(TT)
SUBI TT,1
SOJG T,MPL3
XCT (TT) ; CALL THE FUNCTION
LDB C,[POINT 2,-1(P),2]
TRNE C,2
JRST MAPL2
; ATTACH TO OUTPUT LIST
SKIPN C
PUSHJ P,NCONS
JUMPE A,MAPL2
HLR B,(P)
HRRM A,(B)
SKIPE C
PUSHJ P,LAST
HRLM A,(P)
JRST MAPL2
; POP STACK AND RETURN
MPDN: POP P,AR1
MOVE P,-1(P)
POP P,B
SUBS4: HRRZ A,AR1
POPJ P,
;PA3: 0 ;THE REG. PDL POINTER
;PA4: 0 ;Lh=pntr to prog less bound var list
;RH=NEXT PROG STATEMENT
PROG: PUSH P,PA3#
PUSH P,PA4#
HLRZ TT,(A)
HRRZ A,(A)
HRRM A,PA4
HRLM A,PA4
MOVE T,SP ;$$ADJUST SPDLSAV POINTER TO INCLUDE EVAL BLIP
SUB T,[XWD 2,2] ;$$SO PA3,PA4 CAN BE RESTORED
MOVEM T,SPSV# ;$$BY UNBIND
JRST PG7B ;$$GO CHECK IF ANY VARIABLES TO BIND
PG7A: HLRZ A,(TT)
MOVEI AR1,0
PUSHJ P,BIND
HRRZ TT,(TT)
PG7B: JUMPN TT,PG7A
PUSH SP,SPSV
MOVEM P,PA3
PG1: HRRZ T,PA4
JUMPE T,PG4
HLRZ A,(T)
HRRZ T,(T)
HLLE B,(A)
AOJE B,PG1+1
HRRM T,PA4
PUSH P,SP ;$$SAVE SPDL TO RESTORE AFTER EVAL
PUSHJ P,EVAL
POP P,SP ;$$RESTORE SPDL AFTER EVAL
JRST PG1
PGO: SKIPN PA3
JRST EG2
MOVE P,PA3
MOVE B,1(P)
PUSHJ P,UBD
HLRZ T,PA4
PG5: JUMPE T,EG1
HLRZ TT,(T)
HRRZ T,(T)
CAIN TT,(A)
JRST PG1+1 ;FOUND TAG
JRST PG5
RETURN: SKIPN PA3
JRST EG3
MOVE P,PA3
MOVE B,1(P)
PUSHJ P,UBD
JRST PG4+1
PG4: SETZ A,
PUSHJ P,UNBIND
ERRP4: POP P,PA4
POP P,PA3
POPJ P,
GO: HLRZ A,(A)
HLLE B,(A)
AOJE B,PGO
PUSHJ P,EVAL
JRST GO+1
SETQ: HLRZ B,(A)
PUSH P,B
PUSHJ P,CADR
PUSHJ P,EVAL
MOVE B,A
POP P,A
SET: SKIPE A ;$$ MUST BE NON-NIL
CAILE A,INUMIN ;$$ AND NOT AN INUM
JRST SETERR ;$$
HLRE AR1,(A) ;$$ AND AN ATOM
AOJN AR1,SETERR ;$$
MOVE AR1,B
PUSHJ P,BIND
SUB SP,[XWD 1,1]
MOVE A,AR1
POPJ P,
CON2: HRRZ A,(T)
COND: JUMPE A,CPOPJ ;entry
PUSH P,A
HLRZ A,(A)
HLRZ A,(A)
PUSHJ P,EVAL
POP P,T
JUMPE A,CON2
HLRZ T,(T)
COND2: HRRZ T,(T)
JUMPE T,CPOPJ ;ENTRY FOR ALL TYPES OF PROGN'S
HLRZ A,(T)
HRRZ T,(T) ;$$
JUMPE T,EVAL ;$$ SAVE STACK SPACE IF NO IMPLIED PROG
PUSH P,T ;$$
PUSHJ P,EVAL
POP P,T
JRST COND2+2 ;$$ BECAUSE OF THE LAST CHANGE
;LEXORDER - TRUE IF A IS ALPHAMERICALLY LESS THAT OR EQUAL TO B
LEXORD: MOVE TT,A
PUSHJ P,NUMBERP
JUMPN A,LEX2 ;1ST ARG IS A NUMBER
MOVE A,B
PUSHJ P,NUMBERP
EXCH A,TT
JUMPN TT,FALSE ;1ST=NOT-NUM, 2ND=NUM, DEFINE AS NIL
MOVE T,B
MOVEI B,PNAME(S)
PUSHJ P,GET
EXCH A,T
PUSHJ P,GET
LEX1: JUMPE T,TRUE
JUMPE A,CPOPJ
HLRZ AR1,(A)
MOVE AR1,(AR1)
HLRZ AR2A,(T)
MOVE AR2A,(AR2A)
LSH AR1,-1
LSH AR2A,-1
CAMLE AR1,AR2A
JRST TRUE
CAME AR1,AR2A
JRST FALSE
HRRZ A,(A)
HRRZ T,(T)
JRST LEX1
LEX2: MOVE A,B
PUSHJ P,NUMBERP
EXCH A,TT
JUMPE TT,TRUE ;1ST=NUM, 2ND=NOT-NUM, DEFINE AS TRUE
PUSHJ P,.GREAT ;BOTH NUMBERS, DO (NOT (*GREAT A B))
JRST NOT
PROGN: MOVE T,A ;$$ PROGN
MOVEI A,NIL
JRST COND2+1 ;$$ IMPLIED PROG DOES THE REST
PAGE
SUBTTL ARITHMETIC SUBROUTINES --- PAGE 11
;macro expander -- (foo a b c) => (*foo (*foo a b) c)
EXPAND: MOVE C,B
HRRZ A,(A)
PUSHJ P,REVERSE
JRST EXPA1
EXPN1: MOVE C,B
EXPA1: HRRZ T,(A)
HLRZ A,(A)
JUMPE T,CPOPJ
PUSH P,A
MOVE A,T
PUSHJ P,EXPA1
EXCH A,(P)
PUSHJ P,NCONS
POP P,B
PUSHJ P,XCONS
MOVE B,C
JRST XCONS
PAGE
ADD1: CAILE A,INUMIN
CAIL A,-2
SKIPA B,[INUM0+1]
AOJA A,CPOPJ
.PLUS: JSP C,OP
ADD A,TT
FADR A,TT
SUB1: CAILE A,INUMIN+1
SOJA A,CPOPJ
MOVEI B,INUM0+1
.DIF: JSP C,OP
SUB A,TT
FSBR A,TT
.TIMES: JSP C,OP
IMUL A,TT
FMPR A,TT
.QUO: CAIN B,INUM0
JRST ZERODIV
JSP C,OP
IDIV A,TT
FDVR A,TT
.GREAT: EXCH A,B
JUMPE B,FALSE
.LESS: JUMPE A,CPOPJ
JSP C,OP
JRST COMP2 ;bignums know about me
JRST COMP2
COMP2: CAML A,TT
JRST FALSE
JRST TRUE
.MAX: MOVEI D,.GREAT
SKIPA
.MIN: MOVEI D,.LESS
MOVE AR1,A
MOVE AR2A,B
PUSHJ P,(D)
SKIPN A
MOVE AR1,AR2A
MOVE A,AR1
POPJ P,
PAGE
MAKNUM:
CAIN B,FIXNUM(S)
JRST FIX1A
FLO1A:
MOVEI B,FLONUM(S)
PUSHJ P,FWCONS
JRST ACONS-1
FIX1B: SUBI A,INUM0
MOVEI B,FIXNUM(S)
PUSHJ P,FWCONS
JRST ACONS-1
NUMVLX: JFCL 17,.+1
NUMVAL: CAIG A,INUMIN
JRST NUMAG1
SUBI A,INUM0
MOVEI B,FIXNUM(S)
POPJ P,
NUMAG1: MOVEM A,AR1
HRRZ A,(A)
HLRZ B,(A)
HRRZ A,(A)
CAIE B,FIXNUM(S)
CAIN B,FLONUM(S)
SKIPA A,(A)
NUMV4: SKIPA A,AR1
POPJ P,
NUMV2: PUSHJ P,EPRINT ;bignums know about me
JRST NONNUM
NUMV3: JRST NONNUM ;bignums change me to JRST BIGDIS
PAGE
FLOAT: IDIVI A,400000
SKIPE A
TLC A,254000
TLC B,233000
FADR A,B
POPJ P,
FIX: PUSH P,A
PUSHJ P,NUMVAL
CAIE B,FLONUM(S)
JRST POPAJ
MULI A,400
TSC A,A
JFCL 17,.+1
ASH B,-243(A)
FIX2: JFCL 10,FIXOV ;bignums change me to jfcl 10,bfix
POP P,A
FIX1: MOVE A,B
JRST FIX1A
MINUSP: PUSHJ P,NUMVAL
JUMPGE A,FALSE
JRST TRUE
MINUS: PUSHJ P,NUMVLX
MOVNS A
JFCL 10,@OPOV
JRST MAKNUM
ABS: PUSHJ P,NUMVLX
MOVMS A
JRST MINUS+2
PAGE
DIVIDE: CAIN B,INUM0
JRST ZERODIV
JSP C,OP
JUMPN RDIV ;bignums know about me
JRST ILLNUM
RDIV: IDIV A,TT
PUSH P,B
PUSHJ P,FIX1A
EXCH A,(P)
PUSHJ P,FIX1A
POP P,B
JRST XCONS
REMAINDER:
PUSHJ P,DIVIDE
JRST CDR
FIXOV: ERR1 [SIXBIT /INTEGER OVERFLOW!/]
ZERODIV:ERR1 [SIXBIT /ZERO DIVISOR!/]
FLOOV: ERR1 [SIXBIT /FLOATING OVERFLOW!/]
ILLNUM: ERR1 [SIXBIT /NON-INTEGRAL OPERAND!/]
GCD: JSP C,OP
JUMPA GCD2 ;bignums know about me
JRST ILLNUM
GCD2: MOVMS A
MOVMS TT
;euclid's algorithm
GCD3: CAMG A,TT
EXCH A,TT
JUMPE TT,FIX1A
IDIV A,TT
MOVE A,B
JRST GCD3
PAGE
;general arithmetic op code routine for mixed types
OP: CAIG A,INUMIN
JRST OPA1
SUBI A,INUM0
CAIG B,INUMIN
JRST OPA2
HRREI TT,-INUM0(B)
XCT (C) ;inum op (cannot cause overflow)
FIX1A: ADDI A,INUM0
CAILE A,INUMIN
CAIL A,-1
JRST FIX1B
POPJ P,
OPA1: HRRZ A,(A)
HLRZ T,(A)
HRRZ A,(A)
CAIE T,FIXNUM(S)
JRST OPA6
SKIPA A,(A)
OPA2:
MOVEI T,FIXNUM(S)
CAILE B,INUMIN
JRST OPB2
HRRZ B,(B)
HRRZ TT,(B)
HLRZ B,(B)
CAIE B,FIXNUM(S)
JRST OPA5
SKIPA TT,(TT)
OPB2: HRREI TT,-INUM0(B)
MOVE AR1,A
JFCL 17,.+1
XCT (C) ;fixed pt op
OPOV: JFCL 10,FIXOV ;bignums change this to jfcl 10,fixovl
JRST FIX1A
OPA6: CAILE B,INUMIN
JRST OPB7
HRRZ B,(B)
HRRZ TT,(B)
HLRZ B,(B)
CAIE B,FLONUM(S)
JRST OPB3
CAIE T,FLONUM(S)
JRST NUMV3
MOVE A,(A)
MOVE TT,(TT)
OPR: JFCL 17,.+1
XCT 1(C) ;flt pt op
JFCL 10,FLOOV
JRST FLO1A
OPA5:
CAIE B,FLONUM(S)
JRST NUMV3
PUSHJ P,FLOAT
JRST OPR-1
OPB3:
CAIE B,FIXNUM(S)
JRST NUMV3
SKIPA TT,(TT)
OPB7: HRREI TT,-INUM0(B)
MOVEI B,FIXNUM(S)
CAIE T,FLONUM(S)
JRST NUMV3
MOVE A,(A)
EXCH A,TT
PUSHJ P,FLOAT
EXCH A,TT
JRST OPR
SUBTTL EXPLODE, READLIST AND FRIENDS --- PAGE 12
%FLATSIZEC: SKIPA R,.+1 ;$$ FLATSIZEC - (LENGTH (EXPLODEC))
FLATSIZE: HRRZI R,FLAT2
SETZM FLAT1
PUSHJ P,PRINTA
MOVE A,FLAT1#
JRST FIX1A
FLAT2: AOS FLAT1
POPJ P,
%EXPLODE: SKIPA R,.+1
EXPLODE: HRRZI R,EXPL1
MOVSI AR1,AR1
PUSHJ P,PRINTA
JRST SUBS4
EXPL1: PUSH P,B
PUSH P,C
ANDI A,177
CAIL A,"0"
CAILE A,"9"
JRST EXPL2
ADDI A,INUM0-"0"
JRST EXPL4
EXPL2: PUSH P,AR1
PUSH P,TT
PUSH P,T
LSH A,35
MOVE C,SP
PUSH C,A
MOVEI AR1,1
PUSHJ P,INTER0
POP P,T
POP P,TT
POP P,AR1
EXPL4: PUSHJ P,NCONS
HLR B,AR1
HRRM A,(B)
HRLM A,AR1
POP P,C
JRST POPBJ
PAGE
READLIST: TDZA T,T
MAKNAM: MOVNI T,1
MOVEM T,NOINFG
PUSH P,OLDCH
SETZM OLDCH
JUMPE A,NOLIST
HRRM A,MKNAM3
MOVEI A,MKNAM2
PUSHJ P,READ0
HRRZ T,MKNAM3
CAIE T,-1
JUMPN T,[ERR1 [SIXBIT /MORE THAN ONE S-EXPRESSION-MKNAM!/]]
POP P,OLDCH
POPJ P,
MKNAM2: PUSH P,B
PUSH P,T
PUSH P,TT
HRRZ TT,MKNAM3#
JUMPE TT,MKNAM6
CAIN TT,-1
ERR1 [SIXBIT /READ UNHAPPY-MAKNAM!/]
HRRZ B,(TT)
HRRM B,MKNAM3
HLRZ A,(TT)
CAIGE A,INUMIN
JRST MKNAM5
SUBI A,INUM0-"0"
MKNAM4: POP P,TT
POP P,T
JRST POPBJ
MKNAM5: HLRZ A,(TT)
MOVEI B,PNAME(S)
PUSHJ P,GET
HLRZ A,(A)
LDB A,[POINT 7,(A),6]
JRST MKNAM4
MKNAM6: MOVEI A," "
HLLOS MKNAM3
JRST MKNAM4
; A COUPLE OF FUNCTIONS SO THAT THE PROGRAMMER MAY RETURN CELLS TO THE FREE LIST
FREE: MOVEM F,(A) ;$$ RETURN A SINGLE CELL TO FREE LIST
HRRZ F,A
JRST FALSE
FREELI: JUMPE A,CPOPJ ;$$ RETURN A LIST TO THE FREE LIST
HRRZ B,(A)
MOVEM F,(A)
HRRZ F,A
MOVE A,B
JRST FREELI
APPLY.: CAILE A,INUMIN ;$$ AN APPLY TO HANDLE ANY FUNCTION TYPE
JRST UNDTAG
HLRZ T,(A)
CAIE T,-1
JRST GAPP
HRRZ T,(A)
AAGN: JUMPE T,GAPP
HLRZ TT,(T)
HRRZ T,(T)
CAIN TT,FSUBR(S)
JRST [MOVE A,B
HLRZ T,(T)
JRST (T)]
CAIN TT,FEXPR(S)
JRST [ HLRZ T,(T)
HRL T,A
PUSH P,T
MOVE A,B
JRST APPL.2]
CAIN TT,MACRO(S)
JRST [ PUSHJ P,CONS
JRST EVAL]
CAIN TT,EXPR(S)
JRST GAPP
CAIN TT,SUBR(S)
JRST GAPP
CAIE TT,LSUBR(S)
JRST AAGN
GAPP: HRREI T,-2
PUSH P,A
PUSH P,B
JRST APPLY
SUBTTL EVAL APPLY -- THE INTERPRETER --- PAGE 13
EV3: HLRZ A,(AR1)
MOVEI B,VALUE(S)
PUSHJ P,GET
JUMPE A,UNDFUN ;function object has no definition
HRRZ A,(A)
REMOTE<
XXX4:
UBDPTR: UNBOUND>
HLRZ B,(AR1) ;$$GET ORIGINAL FN NAME
CAME A,B ;$$IF VALUE IS THE SAME THE WE HAVE A LOOP
CAMN A,UBDPTR
JRST UNDFUN
HRRZ B,(AR1) ;eval (cons (cdr a)(cdr ar1))
PUSHJ P,CONS
JRST XXEVAL
PAGE
OEVAL: AOJN T,AEVAL
POP P,A
EVAL: PUSH P,SP ;$$SAVE SPDL
PUSHJ P,XXEVAL ;$$GO DO EVALUATION AS USUAL
POP P,SP ;$$RESTORE SPDL
POPJ P, ;$$AND RETURN TO CALLER
XXEVAL: HRRZM A,AR1
CAILE A,INUMIN
JRST CPOPJ
;$$CODE TO PUT EVAL BLIP ON SPECIAL PDL
PUSH P,B ;$$SAVE WHAT WAS IN B
HRRZI B,-1(P) ;$$GET RPDL POINTER AND OFFSET
HRLI B,UNBOUND(S) ;$$ SET UP RPDL POINTER
PUSH SP,B ;$$ SAVE RPDL POINTER ON SPDL
PUSH SP,A ;$$SAVE EVAL FORM ON SPDL
POP P,B ;$$AND GO OON
HLRZ T,(A) ;;;;;;;;;;;;;
SKIPN ERINT# ;$$CHECK IF DDT (CONTROL H) INTERRUPT OCCURRED
JRST .+4 ;$$SKIP OVER INTERRUPT FEATURE
SETZM ERINT# ;$$TURN OFF INTERRUPT FLAG
PUSHJ P,EPRINT ;$$PRINT OUT WHAT WAS INTERRUPTED
ERR1 [SIXBIT /WAS JUST INTERRUPTED - NOW IN ERRORX!/]
CAIN T,-1
JRST EE1 ;x is atomic
CAILE T,INUMIN
JRST UNDFUN
HLRO TT,(T)
AOJE TT,EE2 ;car (x) is atomic
JRST EXP3
EE1:
EV5: HRRZ AR1,(AR1)
JUMPE AR1,UNBVAR
HLRZ TT,(AR1)
CAIE TT,FLONUM(S)
CAIN TT,FIXNUM(S)
POPJ P,
EVBIG: HRRZ AR1,(AR1) ;bignums know about me
CAIE TT,VALUE(S)
JRST EV5
HLRZ AR1,(AR1)
HRRZ AR1,(AR1)
CAIN AR1,UNBOUND(S)
JRST UNBVAR
MOVEM AR1,A
POPJ P,
PAGE
; HANDLER OF ALISTS AND SPDL CONTEXT POINTERS
ALIST: SKIPE A,-1(P)
PUSHJ P,NUMBERP
MOVEM SP,SPSV
JUMPN A,AEVAL7 ;number
MOVE C,SC2 ;bottom of spec pdl
MOVEM C,AEVAL5#
SETOM AEVAL2
AEVAL8: MOVE C,SP
AEVAL6: CAMN C,AEVAL5 ;bottom spec pdl
JRST AEVAL1 ;done
POP C,T ;pointer for next block
JUMPGE T,AEVAL6 ;$$SKIP ANY EVAL BLIP CRAP
AEVAL4: CAMN C,T
JRST AEVAL6 ;thru with block
POP C,AR1
TLNE AR1,-1 ;$$ TEST FOR EVAL BLIP
JRST .+3
SUB C,[XWD 1,1] ;$$ FOUND ONE, SKIP RPDL WORD
JRST AEVAL4
MOVSS AR1
PUSH SP,(AR1) ;save value cell
HLRM AR1,(AR1) ;store previous value in value cell
HRLM AR1,(SP) ;save pointer to spec pdl loc
JRST AEVAL4
AEVAL: PUSHJ P,ALIST
POP P,A
MOVEI A,UNBIND
EXCH A,(P)
JRST EVAL
PAGE
AEVAL1: SKIPGE AEVAL2
SKIPN B,-1(P)
JRST ABIND3 ;done with binding
;alist binding
MOVE A,B
PUSHJ P,REVERSE
SKIPA
ABIND2: MOVE A,B
HRRZ B,(A)
HLRZ A,(A)
HRRZ AR1,(A)
HLRZ A,(A)
PUSHJ P,BIND
JUMPN B,ABIND2
ABIND3: PUSH SP,SPSV
POPJ P,
;spec pdl binding
AEVAL7: MOVE A,-1(P)
PUSHJ P,NUMVAL
JUMPL A,.+5 ;MAKE SURE IT IS A VALID STACK POINTER
MOVS T,SC2 ;IT'S NOT, MAKE IT VALID
ADD T,A
ADD A,SC2
HRL A,T
CLEARM AEVAL2#
MOVEM A,AEVAL5 ;point to unbind to
JRST AEVAL8
;AEVAL2: 0 ;0 for number, -1 for a-list
PAGE
EE2: HRRZ T,(T)
JUMPE T,EV3
HLRZ TT,(T)
HRRZ T,(T)
CAIN TT,SUBR(S)
JRST ESB
CAIN TT,LSUBR(S)
JRST EELS
CAIN TT,EXPR(S)
JRST AEXP
CAIN TT,FSUBR(S)
JRST EFS
CAIN TT,MACRO(S)
JRST EFM
CAIE TT,FEXPR(S)
JRST EE2
HLRZ T,(T)
HLL T,(AR1)
PUSH P,T
HRRZ A,(A)
APPL.2: TLO A,400000
PUSH P,A
MOVNI T,1
JRST IAPPLY
AEXP: HLRZ T,(T)
HLL T,(AR1)
EXP3: PUSH P,T
HRRZ A,(AR1)
CILIST: JSP TT,ILIST
EXP2: JRST IAPPLY
EFS: HLRZ T,(T)
HRRZ A,(AR1)
JRST (T)
PAGE
ESB: HRRZ A,(AR1)
UUOS2: HLRZ T,(T)
HLL T,(AR1)
PUSH P,T
JSP TT,ILIST
ESB1: JRST .+NACS+1(T)
POP P,A+4
POP P,A+3
POP P,A+2
POP P,A+1
POPAJ: POP P,A
POPJ P,
EFM: HLRZ T,(T)
CALLF 1,(T)
JRST EVAL
PAGE
APPLY: MOVEI TT,AP2
CAME T,[-3]
JRST PDLARG
MOVEM T,APFNG1#
PUSHJ P,ALIST
MOVE T,APFNG1
JSP TT,PDLARG
PUSH P,[UNBIND]
AP2: PUSH P,A
MOVEI T,0
AP3: JUMPE B,IAPPLY ;all args pushed; b has arg list
HLRZ C,(B)
PUSH P,C ;push arg
HRRZ B,(B)
SOJA T,AP3
IAP4: JUMPGE D,TOOFEW ;special case for fexprs
AOJN R,TOOFEW
PUSH P,B
MOVE A,SP
PUSHJ P,FIX1A
EXCH A,(P)
MOVE B,A
MOVNI R,2
SOJA T,IAP5
FUNCT: PUSH P,A
MOVE A,SP
PUSHJ P,FIX1A
POP P,B
HLRZ B,(B)
PUSHJ P,XCONS
MOVEI B,FUNARG(S)
JRST XCONS
PAGE
APFNG: SOS T
MOVEM T,APFNG1
JSP TT,PDLARG ;get args and funarg list
HRRZ A,(A)
HRRZ D,(A) ;a-list pointer
HLRZ A,(A) ;function
HRLZ R,APFNG1 ;no. of args
PUSH P,[UNBIND]
JSP TT,ARGP1 ;replace args and fn name
PUSH P,D ;a-list pointer
PUSHJ P,ALIST ;set up spec pdl
POP P,D
AOS T,APFNG1
;falls through
PAGE
;falls in
IAPPLY: MOVE C,T ;state of world at entrance
ADDI C,(P) ;t has - number of args on pdl
ILP1A: HRRZ B,(C) ;next pdl slot has function- poss fun name in lh
CAILE B,INUMIN
JRST UNDTAC
HLRZ A,(B)
CAIN A,-1
JRST IAP1 ;fn is atomic
CAIN A,LAMBDA(S)
JRST IAPLMB
CAIN A,FUNARG(S)
JRST APFNG
CAIN A,LABEL(S)
JRST APLBL
PUSH P,T
MOVE A,B
PUSHJ P,EVAL
POP P,T
MOVE C,T
ADDI C,(P)
ILP1B: MOVEM A,(C)
JRST ILP1A
IAPXPR: HLRZ A,(B)
JRST ILP1B
IAP1: HRRZ B,(B)
JUMPE B,IAP2
HLRZ TT,(B)
HRRZ B,(B)
CAIN TT,EXPR(S)
JRST IAPXPR
CAIN TT,LSUBR(S)
JRST IAP6
CAIE TT,SUBR(S)
JRST IAP1
HLRZ B,(B)
MOVEM B,(C)
JRST ESB1
PAGE
IAPLMB: HRRZ B,(B)
HLRZ TT,(B)
MOVEM SP,SPSV
HRRZ B,(B)
HLRZ D,(TT)
CAIN D,-1
JUMPN TT, IAP3
MOVE R,T
IPLMB1: JUMPE T,IPLMB2 ;no more args
JUMPE TT,TOMANY ;too many args supplied
IAP5: HLRZ A,(TT)
MOVEI AR1,1(T)
ADD AR1,P
HLLZ D,(AR1)
HRLM A,(AR1)
HRRZ TT,(TT)
AOJA T,IPLMB1
PAGE
IPLMB2: JUMPN TT,IAP4 ;too few args supplied
JUMPE R,IAP69
IPLMB4: POP P,AR1
HLRZ A,AR1
AOJG R,IPLMB3
PUSHJ P,BIND
JRST IPLMB4
IPLMB3: SKIPE BACTRF
JRST APBK1
APBK2: MOVEI A,NIL ;$$SETUP FOR IMPLIED PROG
PUSH SP,SPSV
MOVE T,B ;$$SETUP FOR IMPLIED PROG
PUSHJ P,COND2+1 ;$$INSTEAD OF EVAL
JRST UNBIND
IAP69: POP P,(P)
MOVEI A,NIL ;$$SETUP FOR IMPLIED PROG
MOVE T,B ;$$
JRST COND2+1 ;$$INSTEAD OF EVAL
APBK1: HRRI AR1,CPOPJ
TLNE AR1,-1
PUSH P,AR1
JRST APBK2
IAP6: MOVEI TT,CPOPJ
MOVEM TT,(C)
HLRZ B,(B)
JRST (B)
APLBL: MOVEM SP,SPSV
HRRZ B,(B)
HLRZ A,(B)
HRRZ B,(B)
HLRZ AR1,(B)
MOVEM AR1,(C)
PUSHJ P,BIND
MOVEI A,APLBL1
EXCH A,-1(C)
EXCH A,LBLAD#
HRLI A,LBLAD
PUSH SP,A
PUSH SP,SPSV
JRST IAPPLY
APLBL1: PUSH P,LBLAD
JRST SPECSTR
IAP2: HRRZ A,(C)
MOVEI B,VALUE(S)
PUSHJ P,GET
JUMPE A,UNDTAC
HRRZ A,(A)
HRRZ B,(C) ;$$GET ORIGINAL FN NAME
CAME A,B ;$$IF THE VALUE IS THE SAME THEN WE HAVE A LOOP
CAIN A,UNBOUND(S)
JRST UNDTAC
JRST ILP1B
IAP3: MOVNI AR1,-INUM0(T) ;lexpr call
MOVE A,TT
PUSHJ P,BIND
PUSH P,%ARG
SUBI C,INUM0
HRRM C,%ARG
PUSH SP,SPSV
MOVEI A,NIL ;$$ MORE FOR IMPLIED PROG
MOVE T,B ;$$
PUSHJ P,COND2+1 ;$$ INSTEAD OF EVAL
HRRZ T,%ARG
POP P,%ARG
SUBI T,1-INUM0(P)
HRLI T,-1(T)
ADD P,T
JRST UNBIND
ARG: HRRZ A,@%ARG
POPJ P,
REMOTE<%ARG: XWD A,0>
SETARG: HRRZM B,@%ARG
JRST PROG2
PAGE
BIND: JUMPE A,BNDERR ;$$CAN'T REBIND NIL
CAIN A,TRUTH(S) ;$$SHOULDN'T REBIND T
JRST BNDERR ;$$
PUSH P,B
HRRZM A,BIND3#
BIND2:
MOVEI B,VALUE(S) ;bind atom in a to value in ar1,save
PUSHJ P,GET ;old binding on s pdl
JUMPE A,BIND1 ;add value cell
PUSH SP,(A)
HRLM A,(SP)
HRRM AR1,(A) ;$$THIS WAS HHRZM AR1,(A) WHICH CLOBBERED ATOM POINTER IN MY SYSTEM
POPBJ: POP P,B
POPJ P,
BIND1:
MOVEI B,UNBOUND(S)
MOVE A,BIND3 ;$$SET UP ATOM POINTER FROM SPECIAL CELL
;$$THIS WAS MOVEI A,0
PUSHJ P,CONS
HRRZ B,@BIND3
PUSHJ P,CONS
MOVEI B,VALUE(S)
PUSHJ P,XCONS
HRRM A,@BIND3
MOVE A,BIND3
JRST BIND2
UBD: CAMG SP,B
POPJ P,
HLRZ TT,(SP) ;$$SKIP OVER EVAL BLIPS ETC.
JUMPE TT,.+2 ;$$IF EQUAL TO 0 IT WAS AN EVAL BLIP
JRST PJUBND
SUB SP,[XWD 2,2] ;$$DECREMENT SPDL
JRST UBD ;$$GO BACK AND CHECK
PJUBND: PUSHJ P,UNBIND
JRST UBD
UNBIND:
SPECSTR: MOVE TT,(SP)
CAMN SP,SC2 ;$$CHECK TO AVOID OVERSHOOT
POPJ P, ;$$
SUB SP,[XWD 1,1]
JUMPGE TT,UNBIND ;syncronize stack
UNBND1: CAMN SP,TT
POPJ P,
POP SP,T
CAIN T,(T) ;$$CHECK TO SKIP OVER NEW ITEMS PUT ON SPDL
;$$ALL SUCH ITEMS HAVE 0 LEFT HAND SIDES
JRST PROGUB ;$$THIS IS AN EVAL BLIP - CHECK IF A PROG
MOVSS T
HLRM T,(T) ;$$CHANGED FROM HLRZM T,(T) TO PROTECT NEW ATOM POINTER
JRST UNBND1
PROGUB: HLRZ T,(T) ;$$CHECK FOR A PROG
CAIE T,PROGAT+1(S) ;$$CHECK IF IT IS A PROG
JRST PROGU1 ;$$NOT A PROG, SKIP IT AND GO ON
MOVE T,(SP) ;$$GET THE RPDL POINTER FOR PROG INTO T
ADDI T,2 ;$$INCREMENT TO GET TO WHERE PA3,PA4 SAVED
POP T,PA4 ;$$RESTORE PA4
POP T,PA3 ;$$AND PA3 FROM WHERE THEY WERE SAVED
PROGU1: POP SP,T ;$$ POP RPDL POINTER
JRST UNBND1 ;$$AND GO ON WITH THE UNBINDING
SPECBIND: MOVE TT,SP
SPEC1: LDB R,[POINT 13,(T),ACFLD]
CAILE R,17
JRST SPECX
SKIPE R
MOVE R,(R)
HLL R,@(T) ;$$AGAIN SAVE THE POOR LITTLE ATOM POINTER
EXCH R,@(T)
HRLI R,@(T)
PUSH SP,R
AOJA T,SPEC1
SPECX: PUSH SP,TT
JRST (T)
;random special case compiler run time routines
%AMAKE: PUSH P,A ;make alist for fsubr that requires it
MOVE A,SP
PUSHJ P,FIX1A
MOVE B,A
JRST POPAJ
%UDT: PUSHJ P,PRINT ;error print for undefined computed go tag
STRTIP [SIXBIT /UNDEFINED COMPUTED GO TAG IN !/]
HRRZ R,(P)
PUSHJ P,ERSUB3
JRST ERREND
%LCALL: MOVN A,T ;set up routine for compile lsubr
ADDI A,INUM0
ADDI T,(P)
PUSH P,T
PUSHJ P,(3)
POP P,T
SUBI T,(P)
HRLI T,-1(T)
ADD P,T
POPJ P,
SUBTTL ARRAY SUBROUTINES --- PAGE 14
ARRERR=-1
ARRAY: PUSHJ P,ARRAYS
HRRI AR2A,1(R)
MOVE A,AR2A
PUSH R,[0]
AOBJN A,.-1
ARREND: MOVE A,BPPNR#
MOVEM AR2A,-1(A)
MOVEI A,INUM0+1(R)
MOVEM A,VBPORG(S)
POPJ P,
ARRAYS: PUSH P,A
MOVE A,VBPORG(S)
SUBI A,INUM0
MOVEM A,BPPNR
MOVE A,VBPEND(S)
MOVNI A,-INUM0-2(A)
ADD A,BPPNR ;bporg-bpend+2
HRLM A,BPPNR
POP P,A
HRRZ AR1,(A) ;(cdr l)
HLRZ A,(A) ;(car l)name
HRRZ B,BPPNR
ADDI B,2
MOVEI C,SUBR(S)
PUSHJ P,PUTPROP
HLRZ A,(AR1) ;(cadr l)mode
PUSH P,AR1
PUSHJ P,EVAL ;eval mode
POP P,AR1
MOVEM A,AMODE#
MOVEI C,44
JUMPE A,ARRY1
MOVEI C,-INUM0(A)
CAILE A,INUMIN
JRST ARRY1
MOVEI C,22
HRRZ A,BPPNR
MOVE B,GCMKL
PUSHJ P,CONS
MOVEM A,GCMKL
ARRY1: MOVEM C,BSIZE#
MOVEI A,44
IDIV A,C
MOVEM A,NBYTES#
HRRZ A,(AR1) ;(cddr l)bound pair list
JSP TT,ILIST
AOS R,BPPNR
MOVEI AR1,1 ;ar1 is array size
MOVEI AR2A,0 ;ar2a is cumulative residue
AOJGE T,ARRYS ;single dimension
MOVEI D,A-1
SUB D,T ;d is next ac for array code generation
ARRY2: PUSHJ P,ARRB0
TLC TT,(IMULI)
DPB D,[POINT 4,TT,ACFLD]
PUSH R,TT
CAIN D,A
JRST ARRY3
MOVSI TT,(ADD)
ADDI TT,1(D)
DPB D,[POINT 4,TT,ACFLD]
PUSH R,TT
SOJA D,ARRY2
ARRB0: POP P,TT
EXCH TT,(P)
CAILE TT,INUMIN
JRST ARRB1
HLRZ A,(TT)
HRRZ TT,(TT)
SUBI TT,(A)
ADDI TT,1
JRST ARRB2
ARRB1: MOVEI A,INUM0
SUB TT,A
ARRB2: IMUL A,AR1
IMULB AR1,TT
ADDM A,AR2A
POPJ P,
ARRY3: PUSH R,[ADD A,B]
ARRYS: PUSHJ P,ARRB0
HRRZ TT,BPPNR
MOVEM AR2A,(TT)
HRLI TT,(SUB A,)
PUSH R,TT
PUSH R,[JUMPL A,ARRERR]
MOVE TT,AR1
HRLI TT,(CAIL A,)
PUSH R,TT
PUSH R,[JRST ARRERR]
IDIV AR1,NBYTES ;calc #words in array
SKIPE AR2A ;correct for remainder non-zero
ADDI AR1,1
MOVE TT,NBYTES
SOJE TT,ARRY6
ADDI TT,1
HRLI TT,(IDIVI A,)
PUSH R,TT
MOVN TT,BSIZE
LSH TT,14
HRLI TT,(IMULI B,)
PUSH R,TT
MOVEI TT,44+200
SUB TT,BSIZE
LSH TT,6
ARRY6: ADD TT,BSIZE
LSH TT,6
SKIPE AR2A,AMODE
CAIL AR2A,INUMIN
ADDI TT,40 ;mode not = t
TLC TT,(HRLZI C,)
PUSH R,TT
MOVEI TT,4(R)
HRLI TT,(ADDI C,(A))
PUSH R,TT
PUSH R,[LDB A,C]
HRLZI AR2A,(POPJ P,)
SKIPN TT,AMODE
MOVE AR2A,[JRST FLO1A]
CAIL TT,INUMIN
MOVE AR2A,[JRST FIX1A]
PUSH R,AR2A
MOVS AR2A,AR1
MOVNS AR2A
POPJ P,
PAGE
EXARRAY: PUSH P,A
HLRZ A,(A)
PUSHJ P,GETSYM
JUMPE A,POPAJ
PUSHJ P,NUMVAL
EXCH A,(P)
PUSHJ P,ARRAYS
POP P,A
HRRM A,-2(R)
HRR AR2A,A
JRST ARREND
STORE: PUSH P,A
PUSHJ P,CADR
PUSHJ P,EVAL ;value to store
EXCH A,(P)
HLRZ A,(A)
PUSHJ P,EVAL ;byte pointer returned in c
POP P,A
NSTR: PUSH P,A
TLNE C,40
PUSHJ P,NUMVAL ;numerical array
DPB A,C
POP P,A
POPJ P,
SUBTTL EXAMINE, DEPOSIT , ETC --- PAGE 15
BOOLE: MOVE TT,T
ADDI TT,2(P)
MOVE A,-1(TT)
SUBI A,INUM0
DPB A,[POINT 4,BOOLI,OPFLD-2]
PUSHJ P,BOOLG
MOVE C,A
BOOLL: PUSHJ P,BOOLG
XCT BOOLI
REMOTE<
BOOLI: CLEARB C,A>
JRST BOOLL
BOOLG: CAIL TT,(P)
JRST BOOL1
MOVE A,(TT)
PUSHJ P,NUMVAL
AOJA TT,CPOPJ
BOOL1: HRLI T,-1(T)
ADD P,T
POP P,B
JRST FIX1A
EXAMINE:PUSHJ P,NUMVAL
MOVE A,(A)
JRST FIX1A
DEPOSIT:MOVE C,B
PUSHJ P,NUMVAL
EXCH A,C
PUSHJ P,NUMVAL
MOVEM A,(C)
JRST MAKNUM
LSH: MOVEI C,-INUM0(B)
PUSHJ P,NUMVAL
LSH A,(C)
JRST FIX1A
SUBTTL GARBAGE COLLECTER --- PAGE 16
;garbage collector
GC: PUSHJ P,AGC
JRST FALSE
AGC: SETOM GCFLG ;SET GCFLAG INCASE OF USER CONTROL-C
MOVEM R,RGC#
GCPK1: PUSH P,PA3
PUSH P,PA4
PUSH P,UBDPTR ;special atom UNBOUND; not on OBLIST
PUSH P,MKNAM3
PUSH P,GCMKL ;i/o channel input lists and arrays
PUSH P,BIND3
PUSH P,INITF
GCPK2: PUSH P,[XWD 0,GCP6] ;this is a return address
JRST GCP4
REMOTE<
GCP4: MOVEI S,X ;pdlac, .=bottom of reg pdl + 1
GCP41: BLT S,X ;save ACs 0 through 10 at bottom of regpdl ;pdlac+n
GCP2: CLEARB 0,X ;gc indicator, init. for bit table zero
MOVE A,C3GC
GCP5: BLT A,X ;zero bit tables, .=top of bit tables
JRST GCRET1>
GCRET1: SKIPN GCGAGV
JRST GCP5A
SKIPN F
STRTIP [SIXBIT /←FREE STG EXHAUSTED←!/]
SKIPN FF
STRTIP [SIXBIT /←FULL WORD SPACE EXHAUSTED←!/]
GCP5A: MOVEI TT,1
MOVEI A,0
CALLI A,STIME ;time
MOVNS A
ADDM A,GCTIM#
MOVE C,GCP3# ;.=bottom of reg pdl
GCP6B: MOVE S,P
HLL C,P
MOVEI B,0
GC1: CAMN C,S
POPJ P,
HRRZ A,(C)
GCPI: CAMGE A,GCP# ;.=bottom of bit tables
REMOTE<
GCPP1:
XXX5:FS>
CAMGE A,GCPP1
JRST GCEND
CAML A,GCP1# ;.=bottom of full word space (fws)
JRST GCMFW
MOVE F,(A)
LSHC A,-5
ROT B,5
MOVE AR1,GCBT(B)
TDOE AR1,@GCBTP2 ;bit tab- (fs←-5), .=magic number for sync
JRST GCEND
MOVEM AR1,@GCBTP1 ;bit tab- (fs←-5)
PUSH P,F
HLRZ A,F
JRST GCPI
REMOTE<
GCBTP1: XWD A,0
GCBTP2: XWD A,0
GCMFWS: XWD A,0>
GCMFW: MOVEI AR1,@GCMFWS ;.=- bottom of fws
IDIVI AR1,44
MOVNS AR2A
LSH AR2A,36
ADD AR2A,C2GC
DPB TT,AR2A
GCEND: CAMN P,S
AOJA C,GC1
POP P,A
HRRZS A
JRST GCPI
REMOTE<
GCMKL: XWD 0,[XWD [XWD -NIOCH,CHTAB+FSTCH],0]
C2GC: XWD 430100+AR1,X ;.=bottom of fws bit table
C3GC: 0> ;(bottom bit table)bottom bit table+1
GCBT: XWD 400000,0
ZZ==1B1
XLIST
REPEAT ↑D31,<ZZ
ZZ==ZZ/2>
LIST
GCP6: HRRZ R,SC2
GCP6C: CAIL R,(SP) ;mark sp
JRST GCP6A
PUSH P,(R)
HRRZ C,P
PUSHJ P,GCP6B
SUB P,[XWD 1,1]
AOJA R,GCP6C
GCP6A: HRRZ R,GCMKL ;mark arrays
GCP6D: JUMPE R,GCSWP
HLRZ A,(R)
MOVE D,(A)
GCP6E: PUSH P,(D)
HRRZ C,P
PUSH P,(D)
MOVSS (P)
PUSHJ P,GCP6B
SUB P,[XWD 2,2]
AOBJN D,GCP6E
HRRZ R,(R)
JRST GCP6D
GFSWPP:
PHASE 0
GFSP1==.
JUMPL S,.+3
HRRZM F,(R)
HRRZ F,R
ROT S,1
AOBJN R,.-4
MOVE S,(D)
HRLI R,-40
AOBJN D,GFSP1
LPROG==.
JRST GFSPR
DEPHASE
;garbage collector sweep
GCSWP: MOVSI R,GFSWPP
BLT R,LPROG
MOVEI F,NIL ;will become movei f,-1
MOVE D,C3GCS
JRST XXX3
REMOTE<
XXX3: MOVEI R,FS ;$$ANOTHER FOOLIST REMNANT
GCBTL1: HRLI R,X ;-(32-<fs&37>
MOVE S,(D)
GCBTL2: ROT S,X ;fs&37
AOBJN D,GFSP1
JRST GFSPR>
GFSPR: MOVE A,C1GCS
MOVE B,C2GCS
PUSHJ P,GCS0
SKIPN GCGAGV
JRST GCSPI1
MOVE B,F
PUSHJ P,GCPNT
STRTIP [SIXBIT / FREE STG,!/]
MOVE B,FF
PUSHJ P,GCPNT
STRTIP [SIXBIT / FULL WORDS AVAILABLE←!/]
GCSPI1: HRLZ S,GCSP1# ;bottom of reg pdl+1
BLT S,NACS+3 ;reload ac's
SUB P,[XWD GCPK2-GCPK1,GCPK2-GCPK1] ;restore p
AOSN GCFLG ;CHECK FLAG FOR PENDING INTERRUPT
JRST GCEXIT ;NO- SO NORMAL EXIT
POP P,JOBOPC ;INTERRUPT WILL CONTINUE FROM THE GC RETURN
PUSH P,GCFLG ;GC WILL RETURN TO THE INTERRUPT POINT
SETZM GCFLG ;CLEAR GCFLG
GCEXIT: JUMPE F,[ERR2 [SIXBIT /NO FREE STG LEFT!/]]
JUMPE FF,[ERR2 [SIXBIT /NO FW STG LEFT!/]]
MOVE R,RGC
MOVEI A,0
CALLI A,STIME ;time
ADDM A,GCTIM
MOVE S,ATMOV ;$$RESTORE ATOM OFFSET RELOCATOR (FOOLIST)
;$$HOPEFULLY S IS USED ONLY BY GC AND ATOM RELOCATION
POPJ P,
GCS0: MOVEI FF,0
GCS1: ILDB C,B
JUMPN C,GCS2
HRRZM FF,(A)
HRRZ FF,A
GCS2: AOBJN A,GCS1
POPJ P,
REMOTE<
C1GCS: 0 ;(- length of fws) bottom of fws
C2GCS: XWD 100,0 ;.=bottom of fws bit table
C3GCS: 0 ;-n wds in bt,,bt
>
GCGAG: EXCH A,GCGAGV#
POPJ P,
GCTIME: MOVE A,GCTIM
JRST FIX1A
TIME: MOVEI A,0
CALLI A,STIME
JRST FIX1A
SPEAK: MOVE A,CONSVAL#
JRST FIX1A
GCPNT: MOVEI R,TTYO
MOVEI A,0
JUMPE B,PRINL1
HRRZ B,(B)
AOJA A,.-2
GCING: OUTSTR [ASCIZ /
GARBAGE COLLECTING
/]
POP P,GCFLG ;CAN'T INTERRUPT GC, QUEUE UP THE REQUEST
JRST @JOBOPC
SUBTTL GETSYM --- PAGE 17
R50MAK: PUSHJ P,PNAMUK
PUSH C,[0]
HRLI C,700
HRRI C,(SP)
MOVEI B,0
MK3: ILDB A,C
LDB A,R50FLD
CAMGE B,[50*50*50*50*50]
SKIPN A
POPJ P,
IMULI B,50
ADD B,A
JRST MK3
GETSYM: PUSHJ P,R50MAK
TLO B,040000 ;04 for globals
MOVE C,JOBSYM
MK7: CAMN B,(C)
JRST MK10 ;found
AOBJP C,.+2
AOBJN C,MK7
TLC B,140000 ;10 for locals
TLNE B,100000
JRST MK7-1
JRST FALSE
MK10: MOVE A,1(C) ;value
JRST FIX1A
PUTSYM: PUSH P,B
PUSHJ P,R50MAK
MOVE A,B
TLO A,040000 ;make global
SKIPL JOBSYM
AOS JOBSYM ;increment initial symbol table pointer
MOVN B,[XWD 2,2]
ADDB B,JOBSYM
MOVEM A,(B) ;name
POP P,1(B) ;value
JRST FALSE
PATCH: BLOCK 20
SUBTTL ALVINE AND LOADER INTERFACES --- PAGE 18
;interface to alvine
IFN ALVINE,<
ED: MOVE 10,EDA
JRST (10)
PUSH P,A
HRRZ A,CORUSE
HRRM A,LST
AOS A
HRRM A,EDA#
HRRM A,ED1 ;$$SAVE REENTRY TO EDITOR
AOS ED1# ;$$
MOVSI A,(SIXBIT /ED/)
SETZ D, ;THAT RELOCATION AGAIN - SEE BELOW
PUSHJ P,SYSINI
HRLM A,LST
MOVNS A
PUSHJ P,MORCOR
PUSHJ P,SYSINP+1
POP P,A
JRST ED
GRINDEF:PUSH P,A
PUSHJ P,ED
POP P,A
JRST 2(10)>
EXCISE:
IFN ALVINE<
MOVEI A,ED+2
HRRM A,EDA>
MOVE A,JRELO
SETZM LDFLG# ;initial loader symbol table flag
CALLI A,CORE
JRST .+1
JSP R,IOBRST
JRST TRUE
PAGE
;THIS IS THE NEW IMPROVED VERSION OF SPRINT
; 0(P) = A
; -1(P) = B
; -2(P) = C
; -3(P) = M
; -4(P) = N
; -5(P) = X
SPRINT: SUBI B,INUM0
SPRNT2: PUSH P,A
PUSH P,B
SETZM M#
SETZM CSW#
MOVEM P,STP#
MOVEI B,0
PUSHJ P,DEPTH
SKIPN B,M
JRST .+6
MOVE A,LINL
SUB A,B
SUB A,B
IDIV A,B
CAILE A,14
MOVEI A,14
MOVEM A,CUT#
MOVE A,0(P)
IDIV A,LINL
CAIG B,0
ADD B,LINL
MOVEM B,0(P)
MOVEI C,0
JRST .+3
ISPRIN: PUSH P,A
PUSH P,B
PUSH P,C
PUSH P,[0]
PUSH P,[0]
PUSH P,[0]
MOVE A,B
SUB B,LINL
JUMPLE B,.+3
MOVE A,B
MOVEM A,-4(P)
PUSHJ P,POS
MOVE A,-5(P)
PUSHJ P,PATOM
JUMPE A,.+4
SPRN1: MOVE A,-5(P)
PUSHJ P,PRIN1
JRST SPRN22
MOVE B,LINL
SUB B,-4(P)
ADDI B,1
MOVEM B,0(P)
SUB B,-3(P)
MOVE A,-5(P)
PUSHJ P,FLATLE
JUMPN A,SPRN1
MOVEI A,50
PUSHJ P,TYO
AOS -4(P)
SOS 0(P)
HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN13
HLRZ A,@-5(P)
CAIN A,LAMBDA(S)
JRST LAM
CAIN A,PROGAT+1(S)
JRST PRG
PUSHJ P,PATOM
JUMPE A,SPRN3
HLRZ A,@-5(P)
PUSHJ P,PRIN1
MOVE A,0(P)
SUB A,CHCT
MOVEM A,-1(P)
CAIG A,24
JRST SPRN4
JRST SPRN12+4
SPRN3: MOVE B,0(P)
CAILE B,20
MOVEI B,20
HLRZ A,@-5(P)
PUSHJ P,FLATLE
JUMPE A,SPRN12
MOVEM A,-1(P)
SPRN4: HRRZ A,@-5(P)
MOVEM A,-2(P)
HRRZ A,0(A)
PUSHJ P,PATOM
JUMPN A,SPRN8
MOVE B,-1(P)
CAMG B,CUT
JRST SPRN2
SKIPE CSW
JRST SPRN8
MOVE A,0(P)
SUB A,B
SUBI A,1
MOVEM A,-1(P)
JRST SPRN5
SPRN2: HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,.+3
HLRZ A,@-5(P)
PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
MOVE A,-4(P)
ADD A,-1(P)
ADDI A,1
MOVEM A,-4(P)
JRST SPRN12
SPRN5: MOVE B,-1(P)
HLRZ A,@-2(P)
PUSHJ P,FLATLE
JUMPE A,SPRN8
HRRZ A,@-2(P)
MOVEM A,-2(P)
HRRZ A,0(A)
PUSHJ P,PATOM
JUMPE A,SPRN5
HRRZ B,@-2(P)
JUMPN B,.+3
MOVE B,-1(P)
SOJA B,SPRN7
HRRZ A,@-2(P)
PUSHJ P,FLATSI
SUBI A,INUM0-4
SUB A,-1(P)
MOVN B,A
SPRN7: SUB B,-3(P)
HLRZ A,@-2(P)
PUSHJ P,FLATLE
JUMPN A,SPRN18
SPRN8: HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,.+3
SPRN9: HLRZ A,@-5(P)
PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
CAMN A,-2(P)
JRST SPRN11
MOVE A,-4(P)
PUSHJ P,POS
JRST SPRN9
SPRN11: HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN13
SPRN12: MOVEI C,0
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
HRRZ A,@-5(P)
MOVEM A,-5(P)
JRST SPRN11
SPRN13: HRRZ A,@-5(P)
JUMPE A,.+4
PUSHJ P,FLATSI
SUBI A,INUM0-3
ADDM A,-3(P)
AOS -3(P)
MOVE C,-3(P)
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
SPRN16: HRRZ A,@-5(P)
JUMPE A,SPRN17
MOVEI A,40
PUSHJ P,TYO
MOVEI A,56
PUSHJ P,TYO
MOVEI A,40
PUSHJ P,TYO
HRRZ A,@-5(P)
PUSHJ P,PRIN1
SPRN17: MOVEI A,51
PUSHJ P,TYO
JRST SPRN22
SPRN18: HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,.+3
HLRZ A,@-5(P)
PUSHJ P,PRIN1
MOVEI A,40
PUSHJ P,TYO
HRRZ A,@-5(P)
MOVEM A,-5(P)
MOVE A,LINL
SUB A,CHCT
ADDI A,1
MOVEM A,-4(P)
HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN21
SPRN19: HLRZ A,@-5(P)
PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
HRRZ A,0(A)
PUSHJ P,PATOM
JUMPN A,.+4
MOVE A,-4(P)
PUSHJ P,POS
JRST SPRN19
MOVE A,-4(P)
PUSHJ P,POS
SPRN21: HLRZ A,@-5(P)
PUSHJ P,PRIN1
JRST SPRN16
LAM: PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
MOVE B,-4(P)
MOVEM B,-1(P)
HLRZ A,0(A)
PUSHJ P,PATOM
MOVEI B,6
CAIE A,NIL
ADDI B,1
ADDM B,-4(P)
HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN13
MOVEI C,0
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
MOVE B,-1(P)
MOVEM B,-4(P)
JRST SPRN12+4
PRG: PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
MOVE A,-4(P)
MOVEM A,-1(P)
MOVEI A,5
ADDM A,-4(P)
HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN13
MOVEI C,0
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
MOVE A,0(P)
SUBI A,5
MOVEM A,-2(P)
PRG1: HRRZ A,@-5(P)
MOVEM A,-5(P)
HRRZ A,0(A)
PUSHJ P,PATOM
JUMPN A,PRG3
HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPE A,PRG2
MOVE A,-1(P)
PUSHJ P,POS
HLRZ A,@-5(P)
PUSHJ P,PRIN1
JRST PRG1
PRG2: MOVE A,CHCT
CAMG A,-2(P)
PUSHJ P,TERPRI
MOVEI C,0
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
JRST PRG1
PRG3: HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPE A,SPRN13
MOVE B,-1(P)
MOVEM B,-4(P)
JRST SPRN13
SPRN22: MOVEI A,NIL
SUB P,[XWD 6,6]
POPJ P,
POS: PUSH P,A
PUSH P,[0]
MOVE A,LINL
SUB A,CHCT
ADDI A,1
PUSH P,A
CAMN A,-2(P)
JRST POS4
CAMG A,-2(P)
JRST .+4
PUSHJ P,TERPRI
MOVEI A,1
MOVEM A,0(P)
SUBI A,1
LSH A,-3
ADDI A,1
LSH A,3
ADDI A,1
MOVEM A,-1(P)
CAMLE A,-2(P)
JRST POS3
POS2: MOVEI A,11
PUSHJ P,TYO
MOVE A,-1(P)
MOVEM A,0(P)
ADDI A,10
JRST POS2-3
POS3: AOS A,0(P)
CAMLE A,-2(P)
JRST POS4
MOVEI A,40
PUSHJ P,TYO
JRST POS3
POS4: SUB P,[XWD 3,3]
POPJ P,
FLATLE: JUMPLE B,ABORT+1
SETZM M
MOVEM B,N#
MOVEM P,STP
SCAN: PUSH P,A
PUSHJ P,PATOM
JUMPN A,EXIT1-6
NA: AOS A,M
CAMLE A,N
JRST ABORT
HLRZ A,@0(P)
PUSHJ P,SCAN
HRRZ A,@0(P)
MOVEM A,0(P)
JUMPN A,.+3
AOS A,M
JRST EXIT1-2
MOVE A,0(P)
PUSHJ P,PATOM
JUMPE A,NA
MOVEI A,4
ADDB A,M
CAMLE A,N
JRST ABORT
MOVE A,0(P)
PUSHJ P,FLATSI
SUBI A,INUM0
ADDB A,M
CAMLE A,N
JRST ABORT
EXIT1: SUB P,[XWD 1,1]
POPJ P,
ABORT: MOVE P,STP
MOVEI A,NIL
POPJ P,
DEPTH: PUSH P,A
PUSH P,B
PUSHJ P,PATOM
JUMPN A,D2
AOS A,0(P)
CAMLE A,LINL
JRST OUT+1
CAMLE A,M
MOVEM A,M
MOVE A,-1(P)
PUSH P,A
PUSH P,[0]
D1: HLRZ A,@-3(P)
MOVE B,-2(P)
PUSHJ P,DEPTH
HRRZ A,@-3(P)
MOVEM A,-3(P)
MOVE B,-1(P)
SETCMB C,0(P)
JUMPN C,.+3
HRRZ B,0(B)
MOVEM B,-1(P)
CAMN A,B
JRST OUT
PUSHJ P,PATOM
JUMPE A,D1
SUB P,[XWD 2,2]
D2: SUB P,[XWD 2,2]
POPJ P,
OUT: SETOM CSW
MOVE P,STP
JRST @1(P)
;
;
;(TAB X) TABS TO POSITION X DOING A (TERPRI) IF NECESSARY
;
.TAB: PUSHJ P,NUMVAL
PUSHJ P,POS ;LET POS IN SPRINT DO THE WORK
JRST FALSE
PAGE
; lisp loader interface
; REG. D IS USED SINCE VARIABLES ARE MOVE WHEN LISP IS REENTRANT
LOAD: AOS B,CORUSE
MOVEM B,OLDCU#
MOVEM A,LDPAR#
JUMPE A,LOAD2
MOVE B,VBPORG(S)
SUBI B,INUM0
LOAD2: MOVEM B,RVAL# ;final destination of loaded code
MOVSI A,(SIXBIT /LOD/)
SETZ D,
PUSHJ P,SYSINI
SUBI A,150 ;extra room for locations 0 to 137 and slop
PUSH P,A
MOVNS A ;length(loader)
HRRZM A,LODSIZ#
PUSHJ P,MORCOR ;expand core for loader
MOVEM A,LOWLSP# ;location of blt'ed low lisp
MOVN B,(P) ;length(loader)
ADD B,A
MOVEM B,HVAL# ;temporary destination of loaded code
HRLI A,0
MOVE D,A ;THIS IS THE RELOCATION, THE LOADER WILL SAVE IT
BLT A,(B) ;blt up low lisp
HLL A,NAME+3(D) ;-length(loader)
HRRI A,137-1
PUSHJ P,SYSINP
SKIPE LDFLG(D)
JRST LOAD3
SETOM LDFLG(D)
MOVSI A,(SIXBIT /SYM/)
PUSHJ P,SYSINI
MOVNS A ;length symbols
PUSHJ P,MORCOR ;expand core for symbols
SKIPGE B,JOBSYM
SOS B ;if no symbol table, use original jobsym
HLRZ A,NAME+3(D) ;-length(symbols)
ADDB A,B
HLL A,NAME+3(D) ;symbol table iowd
PUSHJ P,SYSINP
HRRM B,JOBSYM
HLLZ A,NAME+3(D)
ADDM A,JOBSYM
SKIPA
LOAD3: SOS JOBSYM ;want jobsym to point one below 1st symbol
MOVE 3,HVAL(D) ;h
MOVE 5,RVAL(D) ;r
MOVE 2,3
SUB 2,5 ;x=h-r
HRLI 5,12 ;(w)
HRLI 2,11 ;(v)
SETZB 1,4
JSP 0,140 ;call the loader
MOVEM 5,RLAST#(D) ;last location loaded(in final area)
MOVE T,OLDCU(D)
MOVE A,JOBSYM
MOVEM A,JOBSYM(T)
MOVE A,JOBREL
MOVEM A,JOBREL(T) ;update jobrel
HRLZ 0,LOWLSP(D)
SOS LODSIZ(D)
AOBJN 0,.+1
BLT 0,@LODSIZ(D) ;blt down low lisp
MOVE 0,@LOWLSP ;EVERY THING IS FIXED, DON'T NEED REG. D ANYMORE
MOVE B,RLAST
MOVE A,RVAL
HRL A,HVAL
SKIPE LDPAR
JRST BINLD
MOVE C,RLAST ;new coruse
LDRET2: BLT A,(B) ;blt down loaded code
HRRZM C,CORUSE ;top of code loaded
MOVEI B,1
ANDCAM B,JOBSYM
SUB C,JOBSYM ;length of free core
ORCMI C,776000
AOJGE C,START ;no contraction
ADD C,JOBREL ;new top of core
MOVE B,C
PUSHJ P,MOVDWN
HRLM C,JOBSA
CALLI C,CORE ;contract core
JRST .+1
JRST START
BINLD: MOVEI C,INUM0(B)
CAML C,VBPEND(S)
JRST [ SETOM BPSFLG ;bps exceeded
JRST START]
MOVEM C,VBPORG(S) ;updat bporg
SOS C,OLDCU ;old top of core
JRST LDRET2
SYSINI: MOVEM A,NAME+1(D)
IFN SYSPRG,< MOVE A,[XWD SYSPRG,SYSPN]
MOVEM A,NAME+3(D)>
IFE SYSPRG,< SETZM NAME+3(D)>
INIT 17
SYSDEV
0
JRST AIN.4+1
LOOKUP NAME(D)
JRST AIN.7+1
MOVE A,[IOWD 1,NAME+3] ;KLUDGE BECAUSE OF REG. D
ADD A,D
MOVEM A,INLOW(D)
INPUT INLOW(D) ;INPUT SIZE OF FILE
REMOTE<
INLOW: IOWD 1,NAME+3
0>
HLRO A,NAME+3(D)
POPJ P,
REMOTE<
NAME: SIXBIT/ILISP/
0
0
0>
SYSINP: MOVEM A,LST(D)
INPUT LST(D)
STATZ 740000
ERR1 AIN.8
RELEASE
POPJ P,
REMOTE<
LST: 0
0>
PAGE
MOVDWN: HLRZ A,JOBSYM
JUMPE A,MOVS1
ADDI A,1(B)
HRL A,JOBSYM
HRRM A,JOBSYM
BLT A,(B) ;downward blt
POPJ P,
MOVSYM: MOVE B,JOBREL
HRLM B,JOBSA
HLRE A,JOBSYM
JUMPE A,MOVS1
ADDI B,1(A) ;new bottom of symbol table
MOVNI A,1(A)
ADD A,JOBSYM ;last loc of old symbol table
HRRM B,JOBSYM
PUSH P,C
MOVE B,JOBREL ;last loc of new symbol table
MOVE C,(A) ;simulated upward blt
MOVEM C,(B)
SUBI B,1
ADDI A,-1 ;lf+1,rt-1
JUMPL A,.-4
POP P,C
POPJ P,
MOVS1: HRRZM B,JOBSYM
POPJ P,
;enter with size needed in a
;exit with pointer in a to core
MORCOR: PUSH P,B
HRRZ B,JOBSYM
SUB B,CORUSE(D)
SUBM A,B
JUMPL B,EXPND2
ADD B,JOBREL ;new core size
CALLI B,CORE ;expand core
ERR1 [SIXBIT /CANT EXPAND CORE !/]
PUSH P,A
PUSHJ P,MOVSYM
POP P,A
EXPND2: MOVE B,CORUSE(D)
ADDM A,CORUSE(D)
MOVE A,B
POP P,B
POPJ P,
PAGE
SUBTTL HIGH SEGMENT FUNCTIONS
REMOTE<VHGHORG:BHORG>
HGHCOR: JUMPE A,NOWRT ;EXPAND CORE AND SET WRITE STATUS
PUSHJ P,NUMVAL
JUMPLE A,FALSE
CLEARB C,WRTSTS
CALLI C,SETUWP
UWPERR: ERR1 [SIXBIT /CAN'T CHANGE HIGH SEG. WRITE PROTECT!/]
MOVE B,VHGHORG
ADD B,A
HRRZ C,JOBHRL
CAMG B,C
JRST TRUE
IFE STANSW,< HRLZ A,B
CALLI A,CORE >
IFN STANSW,< HRRZ A,B
CALLI A,400015>
ERR1 [SIXBIT /CAN'T EXPAND HIGH SEGMENT!/]
JRST TRUE
NOWRT: MOVEI A,1
MOVEM A,WRTSTS
CALLI A,SETUWP
JRST UWPERR
JRST TRUE
HGHORG: SKIPE A ;SET HIGH ORG. TO A AND RETURN OLD ORG.
PUSHJ P,NUMVAL
PUSH P,A
MOVE A,VHGHORG
MOVEI B,FIXNUM(S)
PUSHJ P,MAKNUM
POP P,B
SKIPE B
MOVEM B,VHGHORG
POPJ P,
HGHEND: HRRZ A,JOBHRL ;GET VALUE OF END OF HIGH SEG.
MOVEI B,FIXNUM(S)
JRST MAKNUM
;SETS THE GETSEG INFO. SO USER CAN HAVE OWN HIGH SEG.
SETSYS: MOVE T,A ;MOVE ARGUMENT FOR UIOSUB
PUSHJ P,IOSUB ;BREAKS DOWN THE SPECIFICATION
CAME A,[SYSNAM] ; *** MJC
; We're not allowing him to name his segment the same as ours, *** MJC
; since that causes problems for ATTSEG, so test for it. *** MJC
JRST GUDSEG ; *** MJC
MOVE B,[SYSDEV] ; But if he's a system hacker *** MJC
CAME B,DEV ; then we let him get away *** MJC
JRST BADSEG ; with it. *** MJC
GUDSEG: MOVEM A,HGHDAT+1 ;SAVE THE FILE NAME
MOVE A,DEV ;GET THE DEVICE AND SAVE IT
MOVEM A,HGHDAT
MOVEM A,INTDAT+1 ; Save it for OPEN, too. *** MJC
MOVE A,PPN ;GET THE PPN AND SAVE IT
MOVEM A,SGPPPN ; *** MJC
MOVEM A,HGHDAT+4
SKIPN A,EXT ; Get extension and save it. *** MJC
MOVE A,[SIXBIT/SEG/] ; No ext -- use SEG instead. *** MJC
MOVEM A,HGHDAT+2 ; Move ext into OPEN stuff. *** MJC
OPEN 0,INTDAT ; Open for dump output. *** MJC
JRST BADSEG ; Couldn't open? *** MJC
ENTER 0,HGHDAT+1 ; Hookup to file. *** MJC
JRST BADSEG ; Couldn't do it? *** MJC
CALLI A,400022 ; Find size of high segment. *** MJC
MOVNS A ; Construct dump mode cmd wd. *** MJC
HRLM A,HGHDAT+4 ; I.e. -length to left half *** MJC
MOVEI A,SHRST-1 ; and <start>-1 to rt half. *** MJC
HRRM A,HGHDAT+4 ; *** MJC
OUTPUT 0,HGHDAT+4 ; *** MJC
CLOSE 0,2 ; Leave no traces *** MJC
JRST FALSE ;RETURN NIL
BADSEG: ERR1 [SIXBIT/ILLEGAL NAME FOR SEGMENT!/] ; *** MJC
JRST FALSE ; *** MJC
REMOTE<WRTSTS: 1>
PAGE
SUBTTL REALLOC CODE --- PAGE 19
STRT:
INALLC: HRRZ A,JOBREL ;SEE IF CORE WAS EXPANDED
CAMN A,JRELO# ;OR NOT
JRST OUTALC ;NO EXPANSION - DON'T REALLOCATE
CAMG A,JRELO# ;CHECK TO SEE IF IT GOT SMALLER!
JRST 4,0 ;YES - BITCH
MOVEM A,JRELO# ;SAVE NEW CORE BOUND
HRLM A,JOBSA
IFN ALVINE,<
MOVEI F,ED+2 ;INDICATE THAT ED WAS OVERWRITTEN
HRRM F,EDA ;SO ED AND GRINDEF WILL BE READ IN IF NEEDED>
INAGN: SETZM NOALIN# ;SET UP TO ASK FOR ALLOCATION
OUTSTR [ASCIZ /
ALLOC? (Y OR N) /] ;ASK USER IF HE WISHES TO SET UP
INCHRW C ;THE ALLOCATION INCREMENTS
CAIGE C,"O"
SETOM NOALIN# ;SET FLAG SO NO INPUT IS DONE LATER
SETFWS: MOVE A,SFWS# ;SAVE OLD SIZE OF FWS
MOVEM A,OSFWS#
SKIPN NOALIN ;SKIP QUESTIONS IF AUTOMATIC
OUTSTR [ASCIZ /
FULL WORD SP. = /]
JSP R,ALLNUM
JUMPN A,.+3
SKIPE INITFW#
ADDI A,440 ;INITIAL ALLOCATION FOR FWS
ADDM A,SFWS# ;ADD EITHER USER INCREMENT OR 0 TO SFWS
MOVE A,FSO# ;SAVE OLD FS ORIGIN
MOVEM A,OFSO# ;FOR RELOCATION
SKIPN NOALIN ;SKIP IF USER DONE
OUTSTR [ASCIZ /
BIN. PROG. SP. = /]
JSP R,ALLNUM
ADDM A,SBPS#
MOVEM A,FSMOVE# ;THE INCREMENT TO SBPS IS THE AMOUNT BY
ADDM A,FSO# ;THE FREE SPACE IS MOVED - UPDATE ORIGIN
SKIPN NOALIN ;SKIPIF USER DONE
OUTSTR [ASCIZ /
REG. PDL. = /]
JSP R,ALLNUM
JUMPN A,.+3
SKIPE INITFW# ;CHECK IF INITIAL ALLOCATION
ADDI A,1000
ADDM A,SRPDL#
MOVN AR1,A ;SAVE IN CASE OF OVERFLOW
SKIPN NOALIN ;SKIP IF USER DONE
OUTSTR [ASCIZ /
SPEC. PDL. = /]
JSP R,ALLNUM
JUMPN A,.+3
SKIPE INITFW# ;CHECK FOR INITIAL ALLOCATION
ADDI A,1000
ADDM A,SSPDL#
MOVN AR2A,A ;SAVE IN CASE OF OVERFLOW
IFN HASH,<
SKIPN INITFW
SETOM NOALIN
SKIPN NOALIN
OUTSTR [ASCIZ /
HASH = /]
JSP R,ALLNUM
CAIG A,BCKETS
JRST OCR
HRRM A,INT1
MOVNS A
HRRM A,RH4
SETOM HASHFG>
OCR: OUTSTR [ASCIZ /
/]
MOVE A,JRELO# ;COMPUTE SIZE OF AVAILABLE CORE
SUBI A,FS ;SO THAT EXTRA CORE CAN BE DISTRIBUTED
SUB A,SBPS ;TAKE OFF CORE ALLOCATED FOR BPS
SUB A,SFS# ;TAKE OFF CORE IN PREVIOUS FS
SUB A,SBT# ;AND ASSOCIATED BIT TABLE
SUB A,SFWS ;TAKE OFF CORE NOW ALLOCATED TO FWS
SUB A,SRPDL ;TAKE OFF CORE NOW ALLOCATED TO RPDL
SUB A,SSPDL ;TAKE OFF CORE NOW ALLOCATED TO SPDL
MOVE F,SFWS ;ESTIMATE SIZE NEEDED FOR BTF
IDIVI F,44
ADDI F,1
SUB A,F ;AND TAKE IT OFF TOTAL
MOVEM F,SBTF# ;ALSO SAVE TO RESTORE LATER
JUMPGE A,ALOK ;MAKE SURE NO OVERFLOW
OUTSTR [ASCIZ /ALLOCATIONS ARE TOO LARGE
/] ; IF SO THEN RETRY
MOVE A,OSFWS
MOVEM A,SFWS ;RESTORE SIZE OF FWS
MOVN A,FSMOVE
ADDM A,SBPS ;RESET SIZE OF BPS
ADDM A,FSO ;AND FS ORGIN
ADDM AR1,SRPDL ;RESET STACKS
ADDM AR2A,SSPDL
JRST INAGN
ALOK: MOVE B,A ;NOW CAN ALLOCATE EXCESS CORE
ACHLOC: ASH B,-4 ;1/16 TO FWS
ADDM B,SFWS
SUB A,B ;TAKE IT OFF REMAINING CORE
SKIPE INITFW
SETZ B,
ASH B,-4 ;1/64 TO PDLS
ADDM B,SSPDL
SUB A,B
ADDM B,SRPDL
SUB A,B ;AND TAKE IT OFF REMAINING CORE
MOVE T,SFWS ;CALCULATE ACTUAL SIZE OF BTF
IDIVI T,44
ADDI T,1
ADD A,SBTF ;REMOVE ESTIMATED LOSS FOR BTF
MOVEM T,SBTF
SUB A,T ;AND TAKE OFF ACTUAL LOSS TO BTF
ADD A,SFS ;ADD BACK ON SPACE FROM OLD FS
ADD A,SBT ;AND ASSOCIATED BT
;GIVING NEW SPACE AVAILABLE FOR
;FS AND BT
MOVE TT,A
IDIVI TT,41 ;SBS = SFS/32. = (SBS + SFS)/33.
ADDI TT,1
MOVEM TT,SBT
SUB A,TT ;TAKE OFF SBT FROM REMAINING CORE
MOVEM A,SFS ;GIVING AVAILABLE SFS
;SET UP REGISTERS FOR GC ETC. SETUP
MOVE A,SFWS ;A ← SFWS
MOVEI B,FS
ADD B,SFS
ADD B,SBPS ;B ← NFWSO (ORIGIN OF NEW FULL WORD SPACE)
MOVE C,SRPDL ;C ← SRPDL
MOVE F,OSFWS ;F ← OLD SIZE OF FWS
HRRM B,GCP1 ;GCP1 ← NFWSO
MOVN SP,B ;-NEW BOTTOM OF FWS
HRRM SP,GCMFWS
HRLZM A,C1GCS
MOVNS C1GCS ;-NEW LENGTH OF FWS
HRRM B,C1GCS ;HAVE FWS POINTER AND COUNT FOR SWEEP
ADD B,A ;NEW FIRST WORD OF BT (FS BIT TABLE)
MOVE SP,FSO ;SP ← NEW ORIGIN OF FS
LSH SP,-5
SUBM B,SP ;NUMBER USED TO FIND BIT TABLE WORD
HRRM SP,GCBTP1 ;FROM FS WORD ADDRESS
HRRM SP,GCBTP2
HRLM B,C3GC ;BOTTOM OF BIT TABLES
HRRM B,GCP2
HRRM B,GCP ;(ALSO UPPER BOUND ON FWS AND FS)
MOVNI SP,-2(TT) ;-SIZE OF BT (TT = SBT)
HRLM SP,C3GCS ;IOWD FOR BIT TABLE SWEEP
HRRM B,C3GCS
MOVE SP,FSO
ANDI SP,37 ;MASK OUT ALL BU LAST FIVE BITS
HRRM SP,GCBTL2 ;MAGIC NUMBER TO POSITION
SUBI SP,40
HRRM SP,GCBTL1
ADDI B,1 ;B ← B + 1
HRRM B,C3GC ;BOTTOM OF FS BIT TABLE + 1
ADDI B,-2(TT) ;GET BOTTOM OF BTF - 1, POINTER IS INCREMENTED
HRRM B,C2GCS ;BEFORE USE
ADDI B,1 ;B ← B + 1
HRRM B,C2GC ;BOTTOM OF FWS BIT TABLE + 1
ADDI B,-1(T) ;SINCE T IS NOW SIZE OF BTF, NOT SBTF-1
HRRM B,GCP5 ;TOP OF BIT TABLES
ADDI B,1 ;BOTTOM OF REG PDL
HRRZ A,RHX2 ;GET OBLIST POINTER
ADD A,FSMOVE ;INCREMENT TO
;ACCOUNT FOR MOVE OF FS
MOVEM A,(B)
HRRM B,GCP3 ;ROOM FOR ACS DURING GC
ADDI B,1 ;B ← B + 1
HRRM B,GCSP1
HRRM B,GCP4 ;ROOM FOR ACS
ADDI B,10 ;B ← B + 10
HRRM B,GCP41 ;TOP OF AC AREA
ADDI B,1 ;B ← B + 1
HRRM B,C2 ;SET UP RPDL POINTER
MOVNI A,-20(C) ;A ← - (C -20) = -(SRPDL - 20)
HRLM A,C2 ;THIS IS THE ACTUAL SIZE OF RPDL
;TAKING INTO ACCOUNT THE AC AREA
HRRZ A,JRELO# ;TOP OF CORE - FOR SPDL PTR
MOVN B,SSPDL
ADD A,B
HRL A,B
MOVEM A,SC2# ;SET UP SPDL POINTER (I HOPE)
MOVN A,A ;CREATE OFFSET FOR STACK POINTERS
ADDI A,INUM0
HRRZM A,SPNM#
SETZM INITFW ;TURN OFF INITIAL ALLOCATION FLAG
;RELOCATE THE FULL WORD SPACE
;GCP1 HOLDS POINTER TO ORIGIN OF NEW FWS
;FWSO# HOLDS POINTER TO ORIGIN OF OLD FWS
;AND F HOLDS SIZE OF OLD FWS (AMOUNT TO BE MOVED)
MOVSI B,F
HRR B,GCP1
MOVE C,FWSO#
HRRZI AR2A,-1(C) ;TAKE THE OPPORTUNITY TO GET ADDRESS
;OF END OF OLD FS (USED LATER)
HRLI C,F
MOVE A,@C ;GET WORD FROM END OF OLD FWS
MOVEM A,@B ;AND MOVE TO END OF NEW FWS
SOJGE F,.-2 ;F COUNTS DOWN WORDS IN OLDFWS
;END OF FWS RELOCATION
MOVE FF,FSMOVE ;GET FAST ACCESS TO RELOCATE SIZE FOR FS
HRRZ F,AR2A
ADD F,FF ;AND FIND WHERE TO PUT WORDS FROM
;END OF OLD FS IN NEW FS
HRRZ AR1,GCP1 ;COMPUTE FWS RELOCATION CONSTANT
SUB AR1,FWSO
;RELOCATE FS - ALSO RELOCATE ALL
;POINTERS TO FS AND TO FWS
REL1: HLRZ A,(AR2A) ;GET CAR POINTER OF OLD FS WORD
JSP R,REL4
HRLM A,(F) ;MOVE CAR TO NEW POSITION
HRRZ A,(AR2A) ;GET CDR PTR
JSP R,REL4 ;CHECK FOR FS RELOCATE
HRRM A,(F)
SUBI F,1 ;F ← F -1
CAMLE AR2A,OFSO ;CHECK TO SEE IF DONE
SOJA AR2A,REL1 ;NO - GO LOOP
HRRZ A,GCMKL ;RELOCATE ARRAYS
JSP R,REL4
HRRZ D,A
MOVEM D,GCMKL
REL5: HLRZ AR2A,(D)
MOVE AR2A,(AR2A)
REL6: HLRZ A,(AR2A)
JSP R,REL4
HRLM A,(AR2A)
HRRZ A,(AR2A)
JSP R,REL4
HRRM A,(AR2A)
AOBJN AR2A,REL6
HRRZ D,(D)
JUMPN D,REL5
SETZM BIND3 ;JUST IN CASE
SKIPE INITF ;DON'T FORGET THE INITFN
ADDM FF,INITF
SKIPE NOUUOF ;RELOCATE FLAGS
ADDM FF,NOUUOF
SKIPE BACTRF
ADDM FF,BACTRF
SKIPE GCGAGV
ADDM FF,GCGAGV
SKIPE RSTSW
ADDM FF,RSTSW
JRST RELFOO
REL4: CAMGE A,EFWSO ;SEE IF BEYOND END OF FWS
CAMGE A,OFSO ;OK - SEE IF MAYBE IN FS
JRST (R)
CAMGE A,FWSO ;SEE IF IN FWS
JRST .+3
ADD A,AR1 ;RELOCATE FWS POINTER
JRST (R)
ADD A,FF ;RELOCATE FS POINTER
JRST (R)
RELFOO: MOVE S,SBPS ;S IS THE RELOCATOR FOR MOST MACRO
MOVEM S,ATMOV ;REFERENCES TO ATOMS AND FS
MOVE A,FSMOVE ;NOW IS THE TIME FOR ALL GOOD MEN TO
ADDM A,VBPEND(S) ;SET BPEND
ADDM A,XXX1 ;AND SOMEOTHER CRAP
ADDM A,XXX2
ADDM A,XXX3
ADDM A,XXX4
ADDM A,XXX5
MOVE A,GCP1
HRRZM A,FWSO
MOVE A,C3GCS
HRRZM A,EFWSO#
OUTALC: CLEARB F,DDTIFG
JSP R,IOBRST
JRST START
;SUBROUTINE FOR NUMBER INPUT
ALLNUM: MOVEI A,0
SKIPE NOALIN#
JRST (R)
INCHRW C
CAIN C,RUBOUT
JRST [OUTSTR [ASCIZ /XXX /]
JRST ALLNUM]
CAIL C,"0"
CAILE C,"9"
JRST BANGCK
ASH A,3
ADDI A,-"0"(C)
JRST ALLNUM+3
BANGCK: CAIE C,LF
JRST (R)
SETOM NOALIN#
JRST (R)
;RETURNS 0 IF NOALIN # 0
;SETS NOALIN # 0 IF IT GETS A LINE FEED INPUT
PAGE
IFN HASH,<
REHASH:
MOVEI A,BFWS(S)
PUSH P,A
HRRM A,RHX2
HRRM A,RHX5
MOVS B,RH4#
ADD B,S ;$$PUT IN ATOM MOVE OFFSET IN B, SINCE CAN'T
;$$DOUBLE INDEX - THIS REMOVES THE FOO PROBLEM
;$$IN THE NEXT THREE FOO'S
HRRZI A,BFWS+1(B)
MOVEM A,BFWS(B)
AOBJN B,.-2
SETZM BFWS(B)
MOVSI AR2A,-BCKETS
HRR AR2A,S ;$$PUT IN ATOM MOVE OFFSET IN AR2A TO AVOID
;$$DOUBLE INDEXING WITH S IN REMOVING FOO
;$$PROBLEM
RH1:
HLRZ C,OBTBL(AR2A)
RH3: JUMPE C,RH2
HLRZ A,(C)
PUSH P,C
PUSH P,AR2A
PUSHJ P,INTERN
POP P,AR2A
POP P,C
HRRZ C,(C)
JRST RH3
RH2: AOBJN AR2A,RH1
SETZM HASHFG
POP P,A
HRRM A,@GCP3
MOVEM A,OBLIST(S)
JRST START>
PAGE
SUBTTL NEW FUNCTIONS TO MAKE USE OF MODIFIED SPECIAL PDL FOR ERRORS
;$$ROUTINE TO GET POINTER TO SPDL AND MAKE IT INTO AN INUM
SPDLPT: HRRZ A,SP ;$$CREATE A POINTER TO THE CURRENT TOP OF STACK
ADD A,SPNM
POPJ P, ;$$
;$$ROUTINE TO GET LEFT HAND SIDE OF SPDL ITEM INDICATED BY AN INUM FROM SPDLPT
SPDLFT: SUB A,SPNM ;$$CONVERT TO ADDRESS
HLRE A,(A) ;$$GET LEFT HAND ITEM
JUMPL A,TRUE ;$$IF IT IS NEGATIVE IT CAME FROM A STACK
;$$POINTER AND WE RETURN T INSTEAD
HRRZI A,(A) ;$$CLEAR OUT LEFT HAND OF AC
POPJ P, ;$$RETURN - RETURNS NIL FOR LHS = 0
;$$ROUTINE TO GIVE RIGHT HAND SIDE OF SPDL ENTRY SPECIFIED BY AN INUM FROM SPDLPT
SPDLRT: SUB A,SPNM ;$$CONVERT TO AN ADDRESS
HRRZ A,(A) ;$$ALL RHS ITEMS ARE LEGAL, NO NEED FOR CHECK
POPJ P, ;$$
;$$ROUTINE TO GET POINTER TO NEXT EVAL BLIP ON SPDL
NEXTEV: SUB A,SPNM ;$$GET POINTER INSTEAD OF INUM
HRRZ T,SC2 ;$$GET POINTER TO BOTTOM OF SPDL
SPDNLP: CAMG A,T ;$$CHECK IF HIT THE BOTTOM OF SPDL
JRST FALSE ;$$RETURN NIL IF NO MORE INTERESTING WORDS
HLL A,(A) ;$$TEST FOR WORD WITH 0 LHS
TLZE A,-1 ;$$
SOJA A,SPDNLP ;$$NOT AN INTERESTING WORD, LOOK AGAIN
ADD A,SPNM ;$$FOUND AN INTERESTING WORD, CHANGE POINTER TO INUM
POPJ P, ;$$
;$$ROUTINE TO EVALUATE A VARIABLE IN AN EARLIER CONTEXT
;$$ MORE EFFICIENT THAN EVAL WITH ALIST
EVALV: MOVE C,A ;$$ MOVE AROUND FOR ATOM CHECK
PUSHJ P,ATOM ;$$
EXCH A,C ;$$
SUB B,SPNM ;$$
EVALV1: CAIN B,(SP) ;$$CHECK FOR END OF SPDL
JRST GETV ;$$VARIABLE NOT REBOUND - GET CURRENT VALUE
SKIPGE ,(B) ;$$CHECK TO AVOID SPDL POINTERS ON STACK
AOJA B,EVALV1 ;$$
HLRZ T,(B) ;$$T←CAR(B)
SKIPE C ;$$
HLRZ T,(T) ;$$GET CAR OF SPECIAL CELL - ATOM POINTER
CAIE T,(A) ;$$COMPARE WITH ATOM TO BE EVALUATED
AOJA B,EVALV1 ;$$NOT IT, LOOK SOME MORE
HRRZ A,(B) ;$$GET VALUE FROM SPDL
POPJ P, ;$$
GETV: JUMPE C,GETV1
MOVEI B,VALUE(S) ;$$ATOM NOT REBOUND, VALUE THEN IS
PUSHJ P,GET ;$$
JUMPE A,UNBOND ;$$NOT BOUND AT ALL, GIVE UNBVAR MESSAGE
GETV1: HRRZ A,(A) ;$$GET CDR OF SPECIAL CELL
POPJ P, ;$$
UNBOND: HRRZI A,UNBOUND(S) ;$$RETURN ATOM UNBOUND
POPJ P, ;$$
;$$ROUTINE TO CLEAR SPECIAL PDL TO POSITION SPECIFIED BY INUM
CLRSPD: MOVEI B,-2-INUM0(A) ;$$ -2 TO GET OVER EVAL BLIP
HLRZ TT,SC2# ;$$GET REAL SPD POINTER WITH A LHS
ADD TT,B ;$$FIND OUT HOW MANY WORDS ARE USED
ADD B,SC2 ;$$
HRL B,TT ;$$SET UP SPD POINTER
JRST UBD ;$$UBD DOES ALL THE WORK
;$$ROUTINE TO RETURN FROM SPECIAL PDL CONTEXT, SPECIFIED BY AN
;$$EVAL BLIP, WITH A GIVEN VALUE
OUTVAL: PUSHJ P,NEXTEV ;$$FORCE TO AN EVAL BLIP
JUMPE A,FALSE ;$$ NO EVAL BLIP, RETURN NIL
HRLZI C,(POPJ P,) ;$$ SET TYPE OF RETURN
JRST SPRE1 ;$$ FINISH UP IN SPREDO
;$$ROUTINE TO RE-EVALUATE EXPRESSION FROM AN EVAL BLIP AND GO ON FROM
;$$ THAT CONTEXT (NOT A USER CALLABLE FUNCTION)
REVAL1: HRRZ P,1(SP) ;$$ RPDL POINTER IS UP ONE
HRRZ T,C2# ;$$
HLRZ TT,C2# ;$$
ADD TT,P ;$$
SUB TT,T ;$$
HRL P,TT ;$$
DOSET: MOVE D,ERRTN ;$$ POP ERRSETS, LOAD CURRENT ERRSET
SKIPE D ;$$DONE IF EMPTY
CAMG D,P ;$$ COMPARE TO CURRENT RPDL
XCT C ;$$ DONE, DO A STRANGE EXIT
SUB D,[XWD 1,1] ;$$ GO DOWN A WORD
POP D,ERRSW ;$$
POP D,ERRTN ;$$
SUB D,[XWD 2,2] ;$$ SKIP PROG JUNK
JRST DOSET ;$$ TRY AGAIN
;$$ROUTINE TO CLEAR SPD TO A GIVEN POINT AND REDO FROM THERE
;$$ A CONTAINS AN SPD INUM POINTER, FORCE IT TO BE EVAL BLIP POINTER
SPREDO: PUSHJ P,NEXTEV ;$$FORCE TO EVAL BLIP POINTER
JUMPE A,CPOPJ ;$$RETURN NIL IF NO EVAL BLIP
MOVE B,A ;$$GET THE EXPRESSION
SUB B,SPNM
HRRZ B,(B)
MOVE C,[JRST EVAL] ;$$SET RETURN
SPRE1: PUSH P,B ;$$SAVE SPDL POINTER
PUSHJ P,CLRSPD ;$$CLEAR OUT SPD - INCLUDES RESTORING PROGS
POP P,A ;$$
JRST REVAL1
;$$ SPREVAL - SIMILAR TO OUTVAL BUT EVALUATES THE GIVEN VALUE
;$$AS OF THE SPECIFIED CONTEXT, EQUIVALENT TO:
;$$ (PROG2 (RPLACD (NUMVAL (SETQ A (NEXTEV A))) B) (SPREDO B))
;
SPREVAL:PUSHJ P,NEXTEV ;$$FORCE TO AN EVAL-BLIP
JUMPE A,CPOPJ ;$$RETURN NIL IF NO EVAL-BLIP
JRST SPRE1-1 ;$$LET SPREDO FINISH UP
;$$COMPUTES A LISP POINTER TO A STACK ENTRY
STKPTR: SUB A,SPNM
POPJ P,
LALL
PAGE
SUBTTL LOW SETMENT INCLUDING REMOTE CODE
RELOC 0
HERE
VAR
XALL
PAGE
SUBTTL LISP ATOMS AND OBLIST --- PAGE 20
FS:
DEFINE MAKBUC (A,%B)
<DEFINE OBT'A <%B=.>
XWD %B,IFN <<BCKETS-1>-A>,<.+1>
IF1 <%B=0>>
DEFINE ADDOB (A,C,%B)
<OBT'A
DEFINE OBT'A<%B=.>
IF1 <%B=0>
XWD C,%B>
DEFINE PUTOB (A,B)
<ZZ==<ASCII +A+>←<-1>
ZZ==-ZZ/BCKETS*BCKETS+ZZ
ADDOB \ZZ,B>
DEFINE PSTRCT (A)
<ZZ==[ASCII +A+]
LENGTH(ZY,<A>)
ZY==<ZY-1>/5
Q1(ZY,ZZ)
>
DEFINE Q1 (N,Z)<
IFN N,<XWD Z,[Q1(N-1,Z+1)]>
IFE N,<XWD Z,0>>
DEFINE MKAT (A,B,C,D)
<XLIST
IRP A< PUTOB A,.+1
D XWD -1,.+1
XWD B,.+1
XWD C'A,.+1
XWD PNAME,.+1
XWD [PSTRCT(A)],0>
LIST>
DEFINE MKAT1 (A,B,C,D)
<XLIST
IRP C <PUTOB C,.+1
XWD -1,.+1
XWD B,.+1
XWD D'A,.+1
XWD PNAME,.+1
XWD [PSTRCT(C)],0>
LIST>
DEFINE LENGTH (A,B)
<A==0
IRPC B,<A==A+1>>
DEFINE ML1 (A)<IRP A,<
V'A: XWD -1,.+1
XWD FIXNUM,[A]
MKAT A,SYM,V
>>
DEFINE MKSY1 (A,B,%C)<
XLIST
%C: XWD -1,.+1
XWD FIXNUM,[A]
PUTOB B,.+1
XWD -1,.+1
XWD SYM,.+1
XWD %C,.+1
XWD PNAME,.+1
XWD [PSTRCT(B)],0
LIST>
DEFINE ML (A)<
XLIST
IRP A,<PUTOB A,.+1
A: XWD -1,.+1
XWD PNAME,.+1
XWD [PSTRCT(A)],0>
LIST>
DEFINE MK (A)<
XLIST
IRP A,<PUTOB A,.+1
XWD -1,.+1
XWD PNAME,.+1
XWD [PSTRCT(A)],0>
LIST>
OBTBL:
OBLIST: ZZ==0
XLIST
REPEAT BCKETS,<MAKBUC \ZZ
ZZ==ZZ+1>
LIST
PAGE
MKAT<RPLACA,RPLACD,MINUS,TERPRI,READ,CAR,CDR,CAAR>,SUBR
MKAT<CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,SUBR
MKAT<CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,SUBR
MKAT<CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,MAKNUM,CONS>,SUBR
MKAT<STRINGP,ATOM,PATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,SASSOC,ASSOC>,SUBR
MKAT<GCGAG,CHRCT,LINELENGTH,NUMBERP,EQUAL,SUBST,GET,INTERN,MEMBER>,SUBR
MKAT<LOAD,MAKNAM,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,SUBR
MKAT<TIME,FIX,SET,PROG2,LENGTH,READLIST,LAST,ADD1,SUB1>,SUBR
MKAT<GCTIME,REVERSE,SPEAK,GC,GETL,BAKGAG,MEMQ>,SUBR
MKAT<PUTPROP,PRINC,FLATSIZE,ERR,EXAMINE,DEPOSIT,LSH>,SUBR
MKAT<NCONS,XCONS,REMPROP,ARG,SETARG,NOUUO,MINUSP>,SUBR
MKAT<OUTC,INC,DDTIN,INITFN,EXCISE,REMAINDER,ABS>,SUBR
MKAT<PROG1,SPRINT,LITATOM,NTHCHAR>,SUBR
IFN STPGAP,<MAKAT<PGLINE>,SUBR>
MKAT EXPLODEC,SUBR,%
MKAT TAB,SUBR,.
MKAT TYO,SUBR,I
MKAT TYI,SUBR,I
CEVAL=.+1
MKAT1 EVAL,SUBR,*EVAL
;$$ REDEF. FOR NEW MAP FUNCTIONS
MKAT<MAPCAN,MAPCON,MAPLIST,MAPCAR,MAP,MAPC>,LSUBR
;$$ GIVE MAPCAN THE DOUBLE NAME MAPCONC
MKAT1 MAPCAN,LSUBR,MAPCONC
PROGAT: MKAT<PROG>,FSUBR
MKAT <PROGN,LIST,COND,SETQ,INPUT,OUTPUT,SETSYS>,FSUBR
IFN ALVINE,<MKAT<GRINDEF>,FSUBR
MKAT<ED>,SUBR>
IFE ALVINE,<MK<GRINDEF>>
MKAT<ERRSET,REMOB,OR,GO,ARRAY,STORE>,FSUBR
MKAT<AND,DEFPROP,CSYM,EXARRAY>,FSUBR
MKAT1 QUOTE,FSUBR,FUNCTION
MKAT1 %CLRBFI,SUBR,CLRBFI
MKAT1 .ERROR,SUBR,ERROR
MKAT1 LINRD,SUBR,LINEREAD
MKAT1 UNBOND,SUBR,UNBOUND
MKAT1 ECHO,SUBR,TTYECHO
MKAT1 FUNCT,FSUBR,*FUNCTION
MKAT <APPEND,NCONC,BOOLE,APPLY>,LSUBR
MKAT EVAL,LSUBR,O
MKAT ASCII,SUBR,A
MKAT QUOTE,FSUBR,,CQUOTE:
MKAT INUM0,SYM
PUTOB T,.+1
TRUTH: XWD -1,.+1
XWD VALUE,.+1
XWD VTRUTH,.+1
XWD PNAME,.+1
XWD [PSTRCT(T)],0
VTRUTH: TRUTH
PUTOB NIL,0
CNIL2: XWD VALUE,.+1
XWD VNIL,.+1
XWD PNAME,.+1
XWD [PSTRCT(NIL)],0
VNIL: NIL
MKSY1 %LCALL,*LCALL
MKSY1 %AMAKE,*AMAKE
MKSY1 %UDT,*UDT
MKSY1 .MAPC,*MAPC
MKSY1 .MAP,*MAP
MKAT1 %NOPOINT,VALUE,*NOPOINT
%NOPOINT: NIL
UNBOUND: XWD -1,.+1
XWD PNAME,.+1
XWD [PSTRCT(UNBOUND)],0
PAGE
MKAT1 EXPN1,SUBR,*EXPAND1
MKAT1 EXPAND,SUBR,*EXPAND
MKAT1 PLUS,SUBR,*PLUS,.
MKAT1 DIF,SUBR,*DIF,.
MKAT1 QUO,SUBR,*QUO,.
MKAT1 TIMES,SUBR,*TIMES,.
MKAT1 APPEND,SUBR,*APPEND,.
MKAT1 RSET,SUBR,*RSET,.
MKAT1 GREAT,SUBR,*GREAT,.
MKAT1 LESS,SUBR,*LESS,.
MKAT1 PUTSYM,SUBR,*PUTSYM
MKAT1 GETSYM,SUBR,*GETSYM
ML1 <SPECBIND,SPECSTR,FIX1A,NSTR>
PUTOB NUMVAL,.+1
XWD -1,.+1
XWD SUBR,.+1
XWD NUMVAL,.+1
XWD SYM,.+3
XWD FIXNUM,[NUMVAL]
XWD -1,.-1
XWD .-1,.+1
XWD PNAME,.+1
XWD [PSTRCT(NUMVAL)],0
MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V
;$$ATOMS FOR DEFINITIONS OF FUNCTIONS FOR NEW SPDL PACKAGE
ML ERRORX
MKAT1 INTPRP,SUBR,INITPROMPT
MKAT1 LSPRET,FSUBR,**TOP**
MKAT<PROMPT,READP,UNTYI,STKPTR,SPREDO,SPREVAL>,SUBR
MKAT<MEMB,NEXTEV>,SUBR
MKAT<SPDLFT,SPDLRT,SPDLPT>,SUBR
MKAT<EVALV,OUTVAL>,SUBR
;$$ MORE EXTENSIONS INCLUDING READ MACROS
ML READMACRO
MKAT1 %FLATSIZEC,SUBR,FLATSIZEC
MKAT <NEQ,CONSP,CHRVAL,SETCHR,MODCHR,COPY,LEXORDER>,SUBR
MKAT <FREE,FREELIST,SYSCLR,HGHCOR,HGHORG,HGHEND>,SUBR
MKAT1 FALSE,FSUBR,SPECIAL
MKAT1 FALSE,FSUBR,NOCALL
MKAT1 FALSE,FSUBR,DECLARE
MKAT1 FALSE,FSUBR,NILL
MKAT1 APPLY.,SUBR,APPLY#
MKAT1 .MAX,SUBR,*MAX
MKAT1 .MIN,SUBR,*MIN
MKAT1 MEMBR.,SUBR,MEMBER#
MKAT1 MEMB,SUBR,MEMQ#
MKAT1 AND.,FSUBR,AND#
MKAT1 OR.,FSUBR,OR#
;$$ THE BREAK VARIABLES WHICH TELL ABOUT DEPTH IN THE BREAK PACKAGE
MKAT1 BIOCHN,VALUE,#%IOCHANS%#
MKAT1 BPMPT,VALUE,#%PROMPTS%#
MKAT1 BINDNT,VALUE,#%INDENT
BIOCHN: NIL
BPMPT: NIL
BINDNT: INUM0
VOBLIST: OBLIST
VBASE: 8+INUM0
VIBASE: 8+INUM0
ML <PNAME,FIXNUM,FLONUM,VALUE,LAMBDA,SUBR,FSUBR,EXPR,FEXPR,SYM,∨
$EOF$,LABEL,FUNARG,LSUBR,MACRO>
PUTOB ?,.+1
QST: XWD -1,.+1
XWD PNAME,.+1
XWD [PSTRCT(?)],0
VBPORG: INUM0
VBPEND: INUM0
;MKAT ACHLOC,SYM
;DONT KNOW WHATS UP HERE, IF NEEDED CHECK ACHLOC
PAGE
;
; ALL THE ATOMS IN THE WHOLE SYSTEM
MK<A,ADD,AFTER,ALIAS,ARGPRINT,ASSOC#,ATM,B,BEFORE,BELOW,BEND1,BF,BI,BIND>
MK<BK,BKE,BKEV,BKEVAL,BKF,BKFNLIST,BKFV,BKPOS,BKPROG,BKSETQ,BKV>
MK<BLOCK,BLOCKED,BO,BORG1,BREAK>
MK<BREAKMACROS,BREAK0,BREAK1,BREAK1ERX,BRKAPPLY>
MK<BRKCOMS,BRKEXP,BRKFN,BRKTYPE,BRKWHEN,BROKEN,BROKENFNS>
MK<BY,C,CAIE,CAIN,CALL,CALLF,CALLF@,CAME,CAMN,CAN'T,CHANGE>
MK<CHNGDFLG,CLEARB,CLEARM,COM,COM0>
MK<COMS,COMSQ,COPYFLG,CPTR,D,DE,DEFSYM,DELETE,DF>
MK<DIFFERENCE,DIFFERENT EXPRESSION,DM,DREVERSE,DRM,DSKIN>
MK<DSKOUT,DSM,DSUBST,E,EDIT,EDIT-SAVE>
MK<EDIT4E,EDIT4F,EDIT4F1,EDIT:,EDITBF,EDIT1,EDITCOMSL>
MK<EDITE,EDITF,EDITFNS,EDITFPAT>
MK<EDITL,EDITL0,EDITL1,EDITMACROS,EDITMBD,EDITMV>
MK<EDITOPS,EDITQF,EDITRACEFN,EDITXTR,EMBED,ENTER ,ERXACTION>
MK<EX,EXCH,EXTRACT,F,F=,FF,FILES-LOADED,FINDFLAG,FNDBRKPT,FOR,FOUND>
MK<FROM,FROM?=,FS,FUNTYPE,G,GETSYM,GREATERP,GRINL,GVAL>
MK<GWD,HERE,HLLZS@,HLRZ,HLRZ@,HRLM@,HRRM,HRRM@,HRRZ,HRRZ@,HRRZS@>
MK<I,IF,IN,INSERT,INSIDE,JCALL,JCALLF,JCALLF@,JRST,JSP>
MK<JUMPE,JUMPN,KLIST,L,L0,L11,L12,LAP,LAPEVAL,LAPLST,LASTAIL>
MK<LASTPOS,LASTWORD,LASTP1,LASTP2,LASTVALUE,LC,LCFLG,LCL,LDIFF,LESSP>
MK<LEXPR,LI,LO,LP,LPQ,LPTLENGTH,LSUBST>
MK<M,MARK,MARKLST,MAX,MAXLEVEL,MAXLEVEL EXCEEDED>
MK<MAXLOOP,MAXLOOP EXCEEDED,MBD,MIN,MOVE,MOVEI,MOVEM>
MK<MOVNI,MV,N,N?,NAMESCHANGED,NEX,NOT BLOCKED,NOT EDITABLE>
MK<NOTHING SAVED,NTH,NX,OCCURRENCES,OK,OLDPROMPT,OPS,ORF,ORR>
MK<P,PLEV,PLUS,POP,POPJ,PP,PREVEV,PRINLEV,PRINTLEV>
MK<PUSH,PUSHJ,PUTSYM,QLIST,QUOTIENT,R,READBUF>
MK<REDEFINED,REMOVE,REPACK,REPLACE,RETFROM,RI,RO>
MK<S,SAVE,SECOND,SELECTQ,SN,SOJE,SOJN>
MK<START,STKCOUNT,STKNAME,STKNTH>
MK<STKSRCH,STOP,SUB,SUBPAIR,SURROUND,SW>
MK<TAILP,TCONC,TDZA,TEST,THIRD,THROUGH,THRU,TIMES,TO>
MK<TOFLG,TOPFLG,TRACE,TRACEDFNS,TTY:,TYPE,UNBLOCK,UNBREAK>
MK<UNBREAK0,UNBREAKABLEFNS,UNDEF,UNDO>
MK<UNDOLST,UNDOLST1,UNDONE,UNFIND,UNTRACE,UP>
MK<UPFINDFLG,USE,USERMACROS,WHEN,WITH,X,XTR,Y,ZZ>
MK<@,<\>,<\#\ >,<\P>,↑,↑↑,←,←←, , , ?, . ,< . UNBOUND)>>
MK<- LOCATION UNCERTAIN, = ,! ,!0,!NX,!UNDO,!VALUE,##>
MK<#1,#2,#3,$%DOTFLG,%%BKPOS,%%CMDL,%%V>
MK<%DEFINE,%DEREAD,%DEVP,%ERDEPTH,%LOOKDPTH,%PREVFN%>
MK<%PRINFN,%READIN,&,& ,<(>,<(DEFPROP >,<)>,*,*ANY*,*RSETERX,-->
MK<-IN-,::,:::,/BREAK1,:,=,==,?=,??>
MK<... , ...],BINARY PROGRAM SPACE EXCEEDED>
MK<NOT A TAIL - LDIFF,NO EVAL BLIP - RETFROM>
MK<BAD ARGUMENT - LCONC,BAD ARGUMENT - TCONC>
MK<DSK:,INIT,LSP,NOT IN SYMBOL TABLE,& UNHAPPY>
MK<ARGUMENTS NOT FOUND,NOT BREAKABLE FUNCTION,ARGUMENT LIST?>
MK<AROUND,BREAKIN,EDBRK,BROKEN-IN,EDVAL,DREMOVE,LCONC,SUBLIS>
MK<EDITDSUBST,MAKEFN,FNDEF,LXPD,WHERE,MESS>
MK<SHOULD BE LIST,SHOULD BE LIST OF ATOMIC ARGUMENTS>
MK<FSUBR -- TAKES ONLY ONE ARGUMENT,UNBREAKABLE UNLESS 'IN' SOMETHING>
MK<EDITV,GRINPROPS,=EDITV,EDITP,ARGS,EDITFINDP>
;ATOMS OF GENERATED FUNCTIONS
MK<SUBFUN1ARGPRINT,SUBFUN1BREAKIN0,SUBFUN1EDITCONT,SUBFUN1EDITL1,SUBFUN1EDOR>
MK<SUBFUN1EDVAL,SUBFUN1ERRCOM>
BFWS:
EFWS: 0
RELOC
XLIST
LIT
LIST
BHORG: 0
RELOC
PAGE
SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY) --- PAGE 21
ALLOC: CLEARM 0,SBPS ;SET UP INITIAL ALLOCATIONS FOR SPACE
HRRZI A,BFWS-FS ;THIS IS THE SIZE OF THE ORIGINAL FS
HRRZM A,SFS
HRRZI A,EFWS-BFWS ;THIS ALLOWS ONLY THE INITIAL
HRRZM A,SFWS ;FWS
HRRZI A,0 ;THE INITIAL ALLOCATION FOR SPDL
HRRZM A,SSPDL
HRRZM A,SRPDL ;AND FOR RPDL IS SET UP IN INALLC
HRRZI A,FS
HRRZM A,FSO ;THIS SETS UP INITIAL FS POINTER
HRRZI A,BFWS ;THIS SETS UP INITIAL FWS ORIGIN POINTER
HRRZM A,FWSO#
HRRZI A,EFWS
HRRZM A,EFWSO#
MOVEI A,FS
ADDM A,VBPORG ;SET UP VARIABLE FOR BPS ORIGIN
SOS A
ADDM A,VBPEND
MOVE A,JOBREL
HRLM A,JOBSA
CALLI RESET
MOVEI A,DDT
CALLI A,2 ;SET UP DDT REENTRY POINT FOR AUTOMATIC CONTROL H
MOVEI A,LISPGO
HRRM A,JOBSA
SETOM INITFW# ;FLAG FOR STANDARD INITIALIZATION OF
SETZM JRELO# ;OF SIZES, AND TO INDICATE CORE WAS EXPANDED
JRST INALLC
DEFINE MKENT (A)<
INTERNAL A>
MKENT <EVBIG,NUMBP2,OPOV,NUMV2,NUMV3,NUMV4,OPR,FLOOV,FIX2>
MKENT <NUM1,NUM3,BPR,FWCONS,FALSE,TRUE,FW0CNS,NCONS>
MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,SASSOC,EQUAL,SUBST>
MKENT <CHCT,LINL,OLDCH,FLATSIZE,TYI,RATOM,CHRCT,TYOD>
MKENT <GET,INTERN,REMOB,MAKNAM,GENSYM,FIX,LENGTH,READLIST,PATOM>
MKENT <LAST,INC,OUTC,FIX1A,NUMVAL,REVERSE,MAPLIST,GC,GETL,PUTPROP>
MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRSET,REMOB,ARRAY,APPEND>
MKENT <SPECBIND,SPECSTR,XCONS,ATOM,READCH,SET,NCONC,PRINC>
MKENT <CONS,ACONS,CTY,FP7A1,TERPRI,LSPRET>
MKENT <TYO,ITYO,IGSTRT,NOINFG,CHRTAB,EVAL,OEVAL,.APPEND,INPUT,OUTPUT>
IFN ALVINE,<MKENT<PSAV1,BKTRC>>
;$$ FOR ALAN'S DIRECT ACCESS INPUT
MKENT <ININBF,TYI2,TYIA,INCH>
;$$ FOR ALVINE
MKENT <PROMPT,INUM0,MEMQ,UNBOUND>
PAGE
END ALLOC